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

コード

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に添付ファイルのファイル名(拡張子込み)を入力。
※拡張子まで入力しないと作動しないため注意!

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

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

結果

全てのメールに添付された。
※添付後直ちに送信されるマクロなので、下記の画像のように送信トレイで確認したい場合はアウトルック側で送受信をオフにする設定をすること。

ちゃんと添付されてる。

注意点

ファイルが添付されたメールは新しく送信されるため、添付する前のメールがアウトルックに残っていると紛らわしいことになる。
赤枠内が添付後のメール、黄色枠内が添付前のメール

間違えて二重に送ってしまうことを防止するため、メールをフォルダにコピーした時点で、アウトルックのメールは消しておくとよい。