'https://www.extendoffice.com/documents/outlook/3747-outlook-auto-download-save-attachments-to-folder.html
'or
'https://www.excelguru.ca/forums/showthread.php?9073-VBA-to-automatically-extract-email-attachments-and-save-them-into-a-specific-file
Sub SetFolder() 'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OL As Outlook.Application
Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
'Dim objFolder As Outlook.MAPIFolder
Dim objFolder As Outlook.Folder 'For Gmail Task's folder
Set OL = CreateObject("Outlook.Application")
'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
'Set objFolder = OL.GetNamespace("MAPI").PickFolder
'Debug.Print objFolder.Name, objFolder.FolderPath
Set objFolder = GetFolderPath("\\Ken@gmail.com\Puppy\Pics", OL)
Debug.Print objFolder.Name, objFolder.FolderPath
End Sub
'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
On Error GoTo GetAttachments_err
' Declare variables
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
If Item.UnRead = True Then 'Add this for checking unread emails
' Save any attachments found
For Each Atmt In Item.Attachments
If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then
' This path must exist! Change folder name as necessary.
FileName = "S:\Maintenance\Test\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
Item.UnRead = False 'Mark email item as read
i = i + 1
End If
Next Atmt
End If
Next Item
' Show summary message
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the S:\Maintenance\Test." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
