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