フォルダの中の複数のメールに一括して指定したファイルを添付して送信するマクロ（アウトルック使用）

コード

Sub メールにファイルを一括添付する()
    Dim objOutlook As Object
    Dim objNamespace As Object
    Dim objFolder As Object
    Dim objMailItem As Object
    Dim objAttachment As Object
    Dim strFolderPath As String
    Dim strPDFPath As String
    Dim strFileName As String
    
    ' Outlookを起動
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    
    ' フォルダのパスを指定
    strFolderPath = ThisWorkbook.Path
    strPDFPath = Range("B1") & "\" & Range("B2")
    
    ' フォルダ内のすべてのファイルに対して処理
    strFileName = Dir(strFolderPath & "\*.msg")
    Do While strFileName <> ""
        ' メールアイテムを作成
        Set objMailItem = objOutlook.CreateItemFromTemplate(strFolderPath & "\" & strFileName)
        
        ' PDFファイルを添付
        Set objAttachment = objMailItem.Attachments.Add(strPDFPath)
        
        ' メールを送信
        objMailItem.Send
        
        ' 次のファイルへ移動
        strFileName = Dir
    Loop
    
    ' リソースを解放
    Set objAttachment = Nothing
    Set objMailItem = Nothing
    Set objFolder = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
    
    MsgBox "添付完了"
End Sub

下準備

添付したいファイルのフォルダパスとファイル名をマクロが入ってるエクセルに入力する。

B1に添付ファイルのフォルダパス、B2に添付ファイルのファイル名（拡張子込み）を入力。
※拡張子まで入力しないと作動しないため注意！

添付したいメールをマクロエクセルと同じフォルダにコピーする。
※アウトルック側に添付する前のメールが残っている場合は紛らわしいので削除しておくとよい。

ここまで準備したらマクロ実行