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

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_") '受信日時を取得してタイトル用に文字列に変換
        
        subfolder = Format(objMsg.ReceivedTime, "yyyymmdd") '受信日時yyyymmddでサブフォルダ名を用意
        frag = Dir(folderPath & subfolder, vbDirectory) 'Dir関数で親フォルダの中にサブフォルダの有無を確認
        If frag = "" Then '親フォルダの中にサブフォルダがない場合(すでにサブフォルダがある場合は何もしない)
            MkDir folderPath & subfolder 'サブフォルダを作成
        End If
        
        For Each objAttach In objMsg.Attachments '受信メールに添付されたファイル毎に処理
            attachFileName = folderPath & subfolder & "\" & recTime & objAttach.Filename 'フォルダパスを付けて添付ファイル名を用意
            'attachFileName = folderPath & subfolder & "\" & objMsg.SenderName & "_" & objMsg.Subject & "_" & recTime & objAttach.Filename '「メールのタイトル＋送信者名＋受信日時＋添付ファイル名」の場合
            objAttach.SaveAsFile attachFileName '添付ファイルを保存
        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