【VBAコード】Outlook添付ファイル一括保存(視聴者様リクエスト)

■■■①受信トレイ→カレントフォルダに保存■■■

Sub SaveAttachmentFiles01()

Dim myNamespace As Namespace

Dim myInbox As Object, myFolder As Object, objItem As Object

Dim strSavePath As String, strFile As String, i As Long, numStartDate As Long

numStartDate = ThisWorkbook.ActiveSheet.Cells(1, 1)

strSavePath = ThisWorkbook.Path 'ファイル保存場所(カレントフォルダ)

Set myNamespace = GetNamespace("MAPI")

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)

Set myFolder = myInbox

For Each objItem In myFolder.Items

With objItem

    If .SentOn >= numStartDate Then

        For i = 1 To .Attachments.Count

        If .Attachments.Item(i) Like "見積書*.xlsx" Then

            strFile = strSavePath & "\" & .Attachments.Item(i)

            .Attachments.Item(i).SaveAsFile strFile

            End If

        Next i

    End If

    End With

Next objItem

    

    MsgBox "Outlookからの取得完了(^O^)v", vbInformation

End Sub

■■■②Outlook サブフォルダ→指定フォルダに保存■■■

Sub SaveAttachmentFiles02()

Dim myNamespace As Namespace

Dim myInbox As Object, myFolder As Object, objItem As Object

Dim strSavePath As String, strFile As String, i As Long, numStartDate As Long

numStartDate = ThisWorkbook.ActiveSheet.Cells(1, 1)

strSavePath = ThisWorkbook.Path & "\販売実績" 'ファイル保存場所(カレントフォルダ→販売実績)

Set myNamespace = GetNamespace("MAPI")

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)

Set myFolder = myInbox.Folders.Item("販売実績")

For Each objItem In myFolder.Items

With objItem

    If .SentOn >= numStartDate Then

        For i = 1 To .Attachments.Count

        If .Attachments.Item(i) Like "販売データ*.xlsx" Then

            strFile = strSavePath & "\" & .Attachments.Item(i)

            .Attachments.Item(i).SaveAsFile strFile

            End If

        Next i

    End If

    End With

Next objItem

    MsgBox "Outlookからの取得完了(^O^)v", vbInformation

End Sub

■■■③Outlook サブフォルダ→ファイル名に日付付加■■■

Sub SaveAttachmentFiles03()

Dim myNamespace As Namespace

Dim myInbox As Object, myFolder As Object, objItem As Object

Dim strSavePath As String, strFile As String, i As Long, numStartDate As Long

numStartDate = ThisWorkbook.ActiveSheet.Cells(1, 1)

strSavePath = ThisWorkbook.Path & "\日報" 'ファイル保存場所(カレントフォルダ→日報)

Set myNamespace = GetNamespace("MAPI")

Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)

Set myFolder = myInbox.Folders.Item("報告").Folders.Item("01_日報")

For Each objItem In myFolder.Items

With objItem

    If .SentOn >= numStartDate Then

        For i = 1 To .Attachments.Count

        If .Attachments.Item(i) Like "日報.xlsx" Then

            strFile = strSavePath & "\" & Left(.Attachments.Item(i), Len(.Attachments.Item(i)) - 5) _

                                                                                & Format(.SentOn, "yyyymmdd") & ".xlsx"

            .Attachments.Item(i).SaveAsFile strFile

            End If

        Next i

    End If

    End With

Next objItem

    MsgBox "Outlookからの取得完了(^O^)v", vbInformation

End Sub