【コピペでOK】Outlookの添付ファイルを自動保存するVBA！添付メールの一括保存マクロ！

前に添付付きメールをもらったけど、どれかわからない…
Outlookの添付ファイルを一括保存したい！

前にもらった添付付きメールがどこに行ったか分からないという経験、誰しもあるのではないでしょうか？そもそも添付ファイルだけを一括保存したいのに、できなくていちいち保存するのはかなり手間がかかる作業です。

本記事では Excelシートに入力した条件 に合わせて、Outlookの添付ファイルを自動で一括保存するVBAを紹介します。なお、保存先フォルダは毎回ダイアログで選択でき、送信者や件名、拡張子なども細かくフィルタ出来るようになっています。このコードを使って、効率化を進めてください。

また、VBA初心者の方でも使用できるよう、使い方も丁寧に解説しています。ぜひ最後まで確認してみてください。

【結論】コピペで使える添付ファイル取得VBA
添付ファイル一括取得VBAの動作と使い方
メール出力VBAの使い方
さいごに

【結論】コピペで使える添付ファイル取得VBA

まずコピペで使えるコードを紹介します。

次のコードをコピペするだけで、添付ファイルの一括取得ができます。

Sub SaveAttachmentsWithConditions()
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFolder As Outlook.Folder
    Dim olItem As Object
    Dim olMail As Outlook.MailItem
    Dim olAtt As Outlook.Attachment
    Dim savePath As String
    Dim fileName As String

    ' 条件用Excelの情報
    Dim xlBook As Workbook
    Dim xlSheet As Worksheet
    Dim dateFrom As Variant, dateTo As Variant
    Dim senderCond As String, receiverCond As String, subjectCond As String
    Dim extCondRaw As String, extList() As String
    Dim fileNameCond As String

    ' 保存先フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "添付ファイルの保存先を選択してください"
        If .Show <> -1 Then Exit Sub
        savePath = .SelectedItems(1) & "\"
    End With

    Set xlBook = ThisWorkbook
    Set xlSheet = ActiveSheet

    ' 条件取得（空欄許容）
    dateFrom = xlSheet.Range("B1").Value
    dateTo = xlSheet.Range("B2").Value
    senderCond = Trim(xlSheet.Range("B3").Value)
    receiverCond = Trim(xlSheet.Range("B4").Value)
    subjectCond = Trim(xlSheet.Range("B5").Value)
    fileNameCond = Trim(xlSheet.Range("B6").Value)
    extCondRaw = Trim(xlSheet.Range("B7").Value)

    If extCondRaw <> "" Then
        extList = Split(LCase(extCondRaw), ",")
    End If

    ' Outlookの受信トレイを対象
    Set olApp = Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    ' Restrictで日付範囲フィルタ作成
    Dim filter As String
    filter = ""
    If IsDate(dateFrom) Then
        filter = "[ReceivedTime] >= '" & Format(dateFrom, "yyyy/mm/dd") & "'"
    End If
    If IsDate(dateTo) Then
        If filter <> "" Then filter = filter & " AND "
        filter = filter & "[ReceivedTime] <= '" & Format(dateTo + 1, "yyyy/mm/dd") & "'"
    End If

    Dim targetItems As Outlook.Items
    If filter <> "" Then
        Set targetItems = olFolder.Items.Restrict(filter)
    Else
        Set targetItems = olFolder.Items
    End If

    targetItems.Sort "ReceivedTime", True

    Dim totalCount As Long, currentCount As Long
    totalCount = targetItems.Count
    currentCount = 0

    For Each olItem In targetItems
        currentCount = currentCount + 1
        Application.StatusBar = "処理中: " & currentCount & " / " & totalCount & _
                                "（" & Format(currentCount / totalCount, "0%") & "）"

        If TypeOf olItem Is MailItem Then
            Set olMail = olItem

            If senderCond <> "" And InStr(1, olMail.SenderEmailAddress, senderCond, vbTextCompare) = 0 Then GoTo SkipMail
            If receiverCond <> "" And InStr(1, olMail.To & olMail.CC, receiverCond, vbTextCompare) = 0 Then GoTo SkipMail
            If subjectCond <> "" And InStr(1, olMail.Subject, subjectCond, vbTextCompare) = 0 Then GoTo SkipMail

            ' 添付ファイル保存処理
            If olMail.Attachments.Count > 0 Then
                For Each olAtt In olMail.Attachments
                    Dim fileExt As String
                    Dim attName As String
                    attName = olAtt.fileName
                    fileExt = LCase(Right(attName, Len(attName) - InStrRev(attName, ".")))

                    ' ファイル名条件に一致しなければスキップ
                    If fileNameCond <> "" And InStr(1, attName, fileNameCond, vbTextCompare) = 0 Then GoTo NextAttachment

                    If extCondRaw = "" Then
                        fileName = savePath & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss_") & attName
                        olAtt.SaveAsFile fileName
                    Else
                        Dim i As Long
                        For i = LBound(extList) To UBound(extList)
                            If "." & fileExt = Trim(extList(i)) Then
                                fileName = savePath & Format(olMail.ReceivedTime, "yyyymmdd_hhnnss_") & attName
                                olAtt.SaveAsFile fileName
                                Exit For
                            End If
                        Next i
                    End If
NextAttachment:
                Next
            End If
        End If
SkipMail:
    Next

    Application.StatusBar = False
    MsgBox "条件に合致するファイルの保存が完了しました。", vbInformation
End Sub

※当サイトで紹介している他のコピペコードは、コチラにまとめています！