Download Attachment From Outlook Saved Mail Item Using VBA

[Excel Fox]

Here's the code

Sub DownloadAndSaveOutlookAttachments()

    Dim objFolder As Outlook.MAPIFolder
    Dim objOlMainItem As Outlook.MailItem
    Dim objOlMainItem2 As Outlook.MailItem
    Dim strFilePath As String
    Dim strTmpMsg As String
    Dim sSavePathFS As String
    Dim blnFlag As Boolean
    Dim objAtc As Attachment
    Dim objAtc2 As Attachment
    Const strSaveFolder As String = "D:\Outlook Attachment\"

    'path for creating attachment objOlMainItem file for stripping
    strFilePath = Environ("TEMP") & "\"
    strTmpMsg = "TemporaryMessageSave.objOlMainItem"

    '===============================================================================
    'If you want to specify a particular folder within the Inbox folder in Outlook, like "temp" folder, use the following code
    '===============================================================================
    'Set objFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    'Set objFolder = objFolder.Folders("Temp")
    '===============================================================================
    '===============================================================================
    
    '===============================================================================
    'To pick a folder yourself, use the following code
    Set objFolder = Application.GetNamespace("MAPI").PickFolder
    '===============================================================================
    '===============================================================================
    If objFolder Is Nothing Then Exit Sub

    For Each objOlMainItem In objFolder.Items
        For Each objAtc In objOlMainItem.Attachments
            blnFlag = False
            If Right$(objAtc.FileName, 3) = "objOlMainItem" Then
                blnFlag = True
                objAtc.SaveAsFile strFilePath & strTmpMsg
                Set objOlMainItem2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
            End If
            If blnFlag Then
                For Each objAtc2 In objOlMainItem2.Attachments
                    sSavePathFS = strSaveFolder & objAtc2.FileName
                    objAtc2.SaveAsFile sSavePathFS
                Next objAtc2
                objOlMainItem2.Delete
            Else
                sSavePathFS = strSaveFolder & objAtc.FileName
                objAtc.SaveAsFile sSavePathFS
            End If
        Next objAtc
    Next objOlMainItem
    If Len(sSavePathFS) Then
        MsgBox "Done"
    Else
        MsgBox "No attachments found"
    End If

End Sub