【Outlook】受信したメールの添付ファイルを自動保存する方法を徹底解説

Option Explicit

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Dim folderPath As String
    Dim entryIDs As Variant
    Dim recTime As String
    Dim attachFileName As String
    Dim i As Long
    
    Dim objMsg As Object
    Dim objAttach As Attachment
    
    folderPath = "C:\Users\Downloads\" '添付ファイルを保存するフォルダパスを指定、最後に\を付けること
    
    entryIDs = Split(EntryIDCollection, ",") '複数のメールを同時受信した際は、複数のIDがカンマ区切りで渡されるため、カンマ区切りでIDを配列に格納
    
    For i = 0 To UBound(entryIDs)
        Set objMsg = Application.Session.GetItemFromID(entryIDs(i)) '受信したメールを取得
        recTime = Format(objMsg.ReceivedTime, "yyyymmdd-hhmm_") '受信日時を取得してタイトル用に文字列に変換
        
        For Each objAttach In objMsg.Attachments '受信メールに添付されたファイル毎に処理
            attachFileName = folderPath & recTime & objAttach.FileName 'フォルダパスを付けて添付ファイル名を用意
            objAttach.SaveAsFile attachFileName '添付ファイルを保存
        Next
    Next i
    
    Set objMsg = Nothing

End Sub

Option Explicit

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Dim folderPath As String        ' 添付ファイルを保存する親フォルダ（実際のユーザー名に修正）
    Dim entryIDs As Variant         ' 新規メールのIDを格納する配列
    Dim recTime As String           ' 受信日時（yyyymmdd-hhmm形式）を格納する変数
    Dim attachFileName As String    ' 保存する添付ファイルのフルパス名
    Dim i As Long                   ' ループ用カウンタ

    Dim objMsg As Object            ' 受信メールのオブジェクト
    Dim objAttach As Attachment     ' 添付ファイルを格納するオブジェクト

    Dim subfolder As String         ' 日付ごとのサブフォルダ名（yyyymmdd形式）
    Dim frag As String              ' サブフォルダの有無を確認するための変数
    
    folderPath = "C:\Users\XXXXX\Downloads\" ' ★実際のユーザー名に修正してください（最後に\をつけること）
    
    entryIDs = Split(EntryIDCollection, ",") ' 複数メールのIDを配列に格納
    
    For i = 0 To UBound(entryIDs)
        
        Set objMsg = Application.Session.GetItemFromID(entryIDs(i)) ' 受信したメールを取得
        recTime = Format(objMsg.ReceivedTime, "yyyymmdd-hhmm_")     ' メールの受信日時を取得（ファイル名に使用）
        
        subfolder = Format(objMsg.ReceivedTime, "yyyymmdd")         ' サブフォルダ名（日付）
        frag = Dir(folderPath & subfolder & "\", vbDirectory)       ' サブフォルダの存在確認
        
        If frag = "" Then                                           ' サブフォルダがない場合に作成
            On Error Resume Next                                    ' 念のためエラー処理
            MkDir folderPath & subfolder                            ' サブフォルダ作成
            On Error GoTo 0
        End If
        
        For Each objAttach In objMsg.Attachments                    ' メールの添付ファイルを1つずつ処理
            attachFileName = folderPath & subfolder & "\" & recTime & objAttach.FileName ' 保存するファイル名を用意（日時付き）
            On Error Resume Next                                    ' ファイル保存時のエラー回避処理
            objAttach.SaveAsFile attachFileName                     ' 添付ファイルを保存
            On Error GoTo 0
        Next
    
    Next i
    
    Set objMsg = Nothing                                            ' オブジェクトの解放（メモリ節約）

End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    
    Dim folderPath As String
    Dim entryIDs As Variant
    Dim recTime As String
    Dim attachFileName As String
    Dim i As Long
    Dim keyword As String
    
    Dim objMsg As Object
    Dim objAttach As attachment
    
    folderPath = "C:\Users\Downloads\" ' 添付ファイルを保存するフォルダパスを指定、最後に\を付けること
    keyword = "特定の文字列" ' チェックしたい特定の文字列を指定
    
    ' フォルダパスが存在するか確認
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "指定したフォルダパスが存在しません: " & folderPath, vbExclamation
        Exit Sub
    End If
    
    On Error GoTo ErrorHandler ' エラーハンドリングを有効にする
    
    entryIDs = Split(EntryIDCollection, ",") ' 複数のメールを同時受信した際は、複数のIDがカンマ区切りで渡されるため、カンマ区切りでIDを配列に格納
    
    For i = 0 To UBound(entryIDs)
        Set objMsg = Application.Session.GetItemFromID(entryIDs(i)) ' 受信したメールを取得
        
        ' メールタイトルに特定の文字列が含まれているかチェック
        If InStr(objMsg.Subject, keyword) > 0 Then
            recTime = Format(objMsg.ReceivedTime, "yyyymmdd-hhmm_") ' 受信日時を取得してタイトル用に文字列に変換
            
            For Each objAttach In objMsg.Attachments ' 受信メールに添付されたファイル毎に処理
                attachFileName = folderPath & recTime & objAttach.FileName ' フォルダパスを付けて添付ファイル名を用意
                objAttach.SaveAsFile attachFileName ' 添付ファイルを保存
            Next objAttach
        End If
    Next i
    
Cleanup:
    On Error Resume Next
    Set objMsg = Nothing
    Set objAttach = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
    Resume Cleanup

End Sub