VBAで、複数ファイルを添付したメールを一括作成したい。

Question

標記の通りなのですが、VBAで、複数ファイルを添付したメールを一括作成したいです。
メールはOutlookです。
複数ファイルというのは、一つのフォルダ上に格納されているファイルではなく、
ある規則性によって作成されているフォルダ内に、格納されているファイルのことを指します。
添付画像のようなファルダ構造になっており、
「通知」フォルダを添付させる用のメールのVBAを起動させると、
各先生配下の、さらにクラス名配下の、「通知」のフォルダ内のファイルが、
各先生に送信されるようにしたいです。

ある特定のフォルダから、エクセル上の「添付キーワード」と一致するファイル名のファイルを各先生あてに送信はできるようにはなったのですが、
上記の太字のような、フォルダ構成を考慮して添付ファイルをつけることができません。
③FileAttachの以下の部分
Dim FileStorePath As String 'ファイル格納パス
FileStorePath = "C:\Outlookテスト\aaa先生\1-1\通知"
を編集して、パス名にも、先生名やクラス名をループで入るようにすればいいのでは、
と思うのですが、うまくいかないため、
各先生配下のいづれのクラスにおいて共通のフォルダ名内のファイルを添付したメールを、クラスごとに作成する方法について、
お力を貸してください。

下に添付のようなエクセルで、宛先などを定義しています。

①main

Enum col '1以降の数値を省略した場合は+1される
    宛先 = 1
    複写
    クラス名
    氏名
    添付キーワード
End Enum
 
Sub main()
 
    'Outlookオブジェクトの作成
    Dim OutlookObj As Outlook.Application
    Set OutlookObj = New Outlook.Application
    
    Dim r As Long
    For r = 2 To Cells(1, 1).End(xlDown).Row
    
        'メールアイテムオブジェクト作成
        Dim mailItemObj As Outlook.MailItem
        Set mailItemObj = OutlookObj.CreateItem(olMailItem)
        
        '添付ファイルオブジェクトの生成
        Dim attachObj As Outlook.Attachments
        Set attachObj = mailItemObj.Attachments
        
        Dim keyword As String
        keyword = Cells(r, col.添付キーワード)
        
        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        If FileAttach(attachObj, keyword) = True Then
        
            'メール本文作成
            Dim mailBody As String
            mailBody = CreateMailBody(r)
            
            'メールアイテム作成
            With mailItemObj
                .To = Cells(r, col.宛先).Value
                .CC = Cells(r, col.複写).Value
                .Subject = Cells(1, "I").Value '件名
                .Body = mailBody '本文
            End With
            
            mailItemObj.Display '下書きを表示
            
            '次のメールアイテムを作成するためいったん破棄
            Set mailItemObj = Nothing
            
        End If
            
    Next r
 
End Sub

②CreateMailBody

' 【機能】Excelシート上の指定行番号のメール本文を作成する
Function CreateMailBody(r As Long) As String
 
    Dim cName As String, sName As String
    cName = Cells(r, col.クラス名).Value
    sName = Cells(r, col.氏名).Value
    
    ' Dim sign As String '署名
    ' sign = Cells(12, "I").Value
    
    Dim mBody As String 'メール本文
    mBody = Cells(2, "I").Value '初期値を設定
    mBody = Replace(mBody, "（クラス名）", cName)
    mBody = Replace(mBody, "（氏名）", sName)
    ' mBody = mBody & vbCrLf & vbCrLf & sign '末尾に署名を付与
    
    CreateMailBody = mBody
 
End Function

③FileAttach

' 処理① キーワードに合致するファイルを添付する
' 処理② 1つ以上のファイルが見つかった場合、Trueを返す
Function FileAttach(attachObj As Object, keyword As String) As Boolean
    
    Dim fileCnt As Long '★添付したファイル数をカウントする
    
    Dim FileStorePath As String 'ファイル格納パス
    FileStorePath = "C:\Outlookテスト\aaa先生\1-1\通知"
 
    Dim FileName As String
    FileName = Dir(FileStorePath & "\" & "*")
    
    'フォルダ内のファイル数、検索を繰り返す&"
    Do While FileName <> ""
        
        'キーワードを含むファイルが見つかったら、下書きアイテムに添付する
        If InStr(FileName, keyword) > 0 Then
            attachObj.Add FileStorePath & "\" & FileName
            fileCnt = fileCnt + 1 '★添付したファイル数
        End If
        
        FileName = Dir()
    
    Loop
    
    Set attachObj = Nothing
    
    '★1以上のファイルを添付した場合Trueを返す
    '（Boolean型の初期値はFalse）
    If fileCnt > 0 Then FileAttach = True
 
End Function

（2020/05/06　追記）
コメントいただいたように、VBAを編集してみたのですが、うまく実行しません…。
エクセルもすこし変更しました。
FileStorePathで指定したフォルダ内を「添付キーワード」で検索するのではなく、
FileStorePathで指定したフォルダ内のファイルをすべてメールに添付したいのですが、
さらにどこを修正したらよいでしょうか…。

③FileAttach（変更版）

' 処理① キーワードに合致するファイルを添付する
' 処理② 1つ以上のファイルが見つかった場合、Trueを返す
Function FileAttach(attachObj As Object, keyword As String) As Boolean

    Dim fileCnt As Long '★添付したファイル数をカウントする

    Dim FileStorePath As String 'ファイル格納パス
    FileStorePath = "C:\Outlookテスト\" & Cells(r, "D") & "先生\" & Cells(r, "E") & "\通知"

    Dim FileName As String
    FileName = Dir(FileStorePath & "\" & "*")

    'フォルダ内のファイル数、検索を繰り返す&"
    Do While FileName <> ""

        'キーワードを含むファイルが見つかったら、下書きアイテムに添付する
        **'↑は無し。FileStorePathに格納されているファイルすべてを送信したい。**
        'If Array(FileName) > 0 Then
        '    attachObj.Add FileStorePath & "\" & FileName
        '    fileCnt = fileCnt + 1 '★添付したファイル数
        'End If

        FileName = Dir()

    Loop

    Set attachObj = Nothing

    '★1以上のファイルを添付した場合Trueを返す
    '（Boolean型の初期値はFalse）
    If fileCnt > 0 Then FileAttach = True

End Function

Answer 1

どこかにフォルダー種別のセル作るか、F列に並べるかして
main()で文字列作って、FileAttachにわたすとか。
例）F列に並べると

FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"）& "先生\" & Cells(r,"E") & "\" & cells(r,"F"）

または専用だと、通知.xlsmには、

FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"）& "先生\" & Cells(r,"E") & "\通知"

とか

追記１
ほぼ完成かと、、keyword使わないので消したほうがいいですね

FileAttach

' 処理① キーワードに合致するファイルを添付する
' 処理② 1つ以上のファイルが見つかった場合、Trueを返す
Function FileAttach(attachObj As Object) As Boolean

    Dim fileCnt As Long '★添付したファイル数をカウントする

    Dim FileStorePath As String 'ファイル格納パス
    FileStorePath = "C:\Outlookテスト\" & Cells(r, "D") & "先生\" & Cells(r, "E") & "\通知"

    Dim FileName As String
    FileName = Dir(FileStorePath & "\" & "*")

    'フォルダ内のファイル数、検索を繰り返す&"
    Do While FileName <> ""
      'Debug.Print FileStorePath & "\" & FileName
      attachObj.Add FileStorePath & "\" & FileName
      fileCnt = fileCnt + 1 '★添付したファイル数
      FileName = Dir()

    Loop

    Set attachObj = Nothing

    '★1以上のファイルを添付した場合Trueを返す
    '（Boolean型の初期値はFalse）
    If fileCnt > 0 Then FileAttach = True

End Function

main修正前

   Dim keyword As String
        keyword = Cells(r, col.添付キーワード)

        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        If FileAttach(attachObj, keyword) = True Then

main修正後

   
        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        If FileAttach(attachObj) = True Then

追記２

Dim Col As Colsを宣言することによて、クラス名と先生氏名がぶら下がり、Col.クラス名とCol.先生氏名が使えるようになります。ステップ実行やブレークポイントで止めてColをクイックウォッチに登録すると右のようにColの下にクラス名 As Longと先生氏名 As Longがあるのがわかると思います。

追記３
全体の流れ見ていませんでした、すみません。
main()でファイルパス作って、FileAttachに渡さないといけなかったです。

Enum Col '1以降の数値を省略した場合は+1される
    宛先 = 1
    複写
    クラス名
    氏名
    添付キーワード
    先生氏名
End Enum

Sub main()
    Dim Col As Cols
    Dim r As Long
    'Outlookオブジェクトの作成
    Dim OutlookObj As Outlook.Application
    Set OutlookObj = New Outlook.Application

    Dim r As Long
    For r = 2 To Cells(1, 1).End(xlDown).Row

        'メールアイテムオブジェクト作成
        Dim mailItemObj As Outlook.MailItem
        Set mailItemObj = OutlookObj.CreateItem(olMailItem)

        '添付ファイルオブジェクトの生成
        Dim attachObj As Outlook.Attachments
        Set attachObj = mailItemObj.Attachments

        Dim cName As String, sName As String, tName As String
        cName = Cells(r, Col.クラス名).Value
        tName = Cells(r, Col.先生氏名).Value

        FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知"

        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        If FileAttach(attachObj, FileStorePath) = True Then

            'メール本文作成
            Dim mailBody As String
            mailBody = CreateMailBody(r)

            'メールアイテム作成
            With mailItemObj
                .To = Cells(r, Col.宛先).Value
                .CC = Cells(r, Col.複写).Value
                .Subject = Cells(1, "I").Value '件名
                .Body = mailBody '本文
            End With

            mailItemObj.Display '下書きを表示

            '次のメールアイテムを作成するためいったん破棄
            Set mailItemObj = Nothing

        End If
End Sub

Function FileAttach(attachObj As Object, FileStorePath As String) As Boolean

    Dim fileCnt As Long '★添付したファイル数をカウントする

    Dim FileName As String
    FileName = Dir(FileStorePath & "\" & "*")

    'フォルダ内のファイル数、検索を繰り返す&"
    Do While FileName <> ""
      attachObj.Add FileStorePath & "\" & FileName
      fileCnt = fileCnt + 1 '★添付したファイル数
      FileName = Dir()
      
      FileName = Dir()
    Loop

    Set attachObj = Nothing

    '★1以上のファイルを添付した場合Trueを返す
    '（Boolean型の初期値はFalse）
    If fileCnt > 0 Then FileAttach = True

End Function

Comments

[oftn]

いったん動くものを作りたいので、「通知」専用で作っていまして、
2つ目に書いていただいた
FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"）& "先生\" & Cells(r,"E") & "\通知"
を入れてみました。
かつ「添付キーワード」でFileStorePath内を検索するのではなく、FileStorePath内のファイルをすべて添付したいと思っているので、修正してみたのですが、動きません。
不勉強で申し訳ないのですが、どこを修正すればよいか、もしお時間ありましたら指摘いただけると幸いです。

[oftn]

追記ありがとうございます。
FileStorePath = "C:\Outlookテスト\" & Cells(r,"D"）& "先生\" & Cells(r,"E") & "\通知"
の、Cells(r,"D"）/　Cells(r,"E")　の部分でエラーになってしまうので、先にtNameらの変数宣言をしてからFileAttach
に変数を入れてみたのですが、それでも「アプリケーション定義またはオブジェクト定義のエラーです」と、tNameの宣言のところで出てしまいます。
CellsはFileAttach内ではここでしか使っていないと思うのですが、何か解決策をご存じでしょうか…。
何度も申し訳ありません…。

【FileAttach内】

Dim cName As String, sName As String, tName As String
cName = Cells(r, col.クラス名).Value
tName = Cells(r, col.先生氏名).Value

FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知"

[sinzou]

下記テスト願います。
実行時シートの確認と行、列番号入れ替えて確認してください

Type Cols
クラス名 As Long
先生氏名 As Long
End Type
Sub tes()
Dim Col As Cols
Dim r As Long
'設定
r = 3 '３行目
Col.クラス名 = 3 'C列
Col.先生氏名 = 6 'F列
'テスト
Dim cName As String, sName As String, tName As String
cName = Cells(r, Col.クラス名).Value
tName = Cells(r, Col.先生氏名).Value

FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\通知"
MsgBox FileStorePath
End Sub

[sinzou]

列番号や英字でなく項目名から列を指定したいですか？

Col.クラス名 = Range("1:1").Find("クラス名").Column
Col.先生氏名 = Range("1:1").Find("先生氏名").Column

[oftn]

列番号で列を指定したいです。
列とシートを確認してtesを実行すると、「C:\Outlookテスト\aaa先生\1-2\通知」と表示されます。
mainを実行したところ、エラー1004はなくなったのですが、
ファイルが通知フォルダ配下にあるにも関わらず、
メールが一通も作成されません。
FileAttachでデバッグをしてみたところ、rがnullになってしまっており、cName、tNameの値が取れていないようです。

[sinzou]

Cells(1, 1).End(xlDown).Row は、
A1セル選択後、Endキー押してから下矢印キー押したときのセル位置の行取得しています。
一度キー操作して何行目になるか確認願います。

[oftn]

5行目になりました。

いったんcNameとtNameを別に宣言するのを、
FileStorePath内で定義するスクリプトに戻し、
デバッグで、Cells(r, Col.クラス名)上にカーソルを合わせると、
Cells(r, Col.クラス名)＝<アプリケーション定義またはオブジェクト定義の定義のエラーです>
r=Empty 値
の二つが表示されます。

[sinzou]

追記２しました。

[sinzou]

追記３、全体の流れ見てませんでした。すみません
追記２無視してください。今回使わないです。

[oftn]

丁寧にありがとうございます。
FileStorePathはmainで定義しないといけなかったんですね。
解決しました。
ありがとうございました。

Answer 2

もっといい方法があるかもしれませんが、
③FileAttach内FileStorePathを再帰処理で求めます。

FileStorePath =　getTgtPath("C:\Outlookテスト", keyword) & "\通知"

Function getTgtPath(FPath As String, keyword As String)
'  keywordを含むフォルダーパスを返す
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(FPath).SubFolders
        If InStr(Folder.Name, keyword) > 0 Then
            getTgtPath = Folder.Path: Exit Function
        Else
            Call getTgtPath(Folder.Path, keyword)
        End If
    Next Folder
End Function