複数のメールを一括作成するマクロを組んだのですが、パスの取得を可変にしたところ、ループが回らなくなりました。

Question

表記の通りです。
まずメールを一括作成するマクロを組み、そこまでは目的の動作を果たしてくれました。
そこで、最後のフォルダ名が異なるだけのほとんど一緒のフォルダ構成のフォルダのいくつかで、同様の動作を行いたいため、ファイルを取得するパスを可変にするため、
ボタンを作成し、ボタンの変数をmain()に渡すようにしました。
ボタンで渡す変数名はfNameとし、
フォルダ構成の「初日時点」「中日時点」「最終通知」をボタンによって渡しています。
(※当初はフォルダ名と同様「1日時点」「15日時点」だったのですが、先頭数字は渡せないと知り、
ボタン名とフォルダ名を上記のものに変更したため、
画像はすこし古いものです。)

ボタンの作成には成功し、変数を渡せるようになったのですが、
メールは1通目しか作られません。
デバッグしてみると、
対象フォルダにファイルがあれば、ファイルの数だけ繰り替えすループが、2通目以降は飛ばされてしまっているようです。
どなたか解決のお力を貸していただけないでしょうか。

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

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

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

    **'フォルダ内のファイル数、検索を繰り返す&"**
    **'↓Do While にかかると、2通目以降は飛ばされてしまう部分"**
    Do While 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

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

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

    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

        Dim FileStorePath As String
        FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName &　"\" & fName

        '★添付ファイルが存在する場合のみ、メールアイテムを作成する
        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

    Next r

End Sub

Comments

[ttyp03]

Dirのループが回らない原因はDirに渡しているパスが正しくないときのみです。
FileAttachに渡されるFileStorePathが正しいことは確認できていますか？

[oftn]

ひとつめのVBAの5行目に、MsgBox FileStorePathをつけて確認しましたが、FileStorePathは正しく表示されます。「OK」を押下すると、次のパスがループで表示されます。
そのため、1通目のメールも作れているのだと認識しています。

[tosi]

FileName = Dir(FileStorePath & "\" & "*")
MsgBox FileStorePath
ここで確認するのはFileNameの方が良いです。
(FileStorePathの確認はモジュールの先頭部分)
MsgBox FileNameで文字列取れていますか？
無い場合はフォルダ名とその存在を確認します。
目視で絶対に大丈夫であれば、フォルダ存在確認処理をモジュール先頭部へ入れる必要が出てくるかと思われます。

Answer 1

フォルダーとファイルチェックしてみてください。

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

Sub tes(fName As String)
   
    Dim r As Long
    Dim cName As String, sName As String, tName As String
    Dim FileStorePath As String
    Dim FileNameS As String
    Dim FileName As String
    
    For r = 2 To Cells(1, 3).End(xlDown).Row
 
        cName = Cells(r, Col.クラス名).Value
        tName = Cells(r, Col.先生氏名).Value
        
        FileStorePath = "C:\Outlookテスト\" & tName & "先生\" & cName & "\" & fName
        
        FileName = Dir(FileStorePath, vbDirectory)
        If FileName = "" Then
              FileNameS = "フォルダー見つかりません。" & FileStorePath
        Else
              FileNameS = "対象フォルダー" & FileStorePath & vbCrLf
              FileName = Dir(FileStorePath & "\" & "*")
              Do While FileName <> ""
                  FileNameS = FileNameS & FileName & vbCrLf
                  FileName = Dir()
              Loop
        End If
        MsgBox FileNameS
    Next r

End Sub

Comments

[oftn]

上記のテストをしたところ、値が取れていない箇所がわかりました。ありがとうございました。