Sub SaveAttachmentsToFolder() ' This Outlook macro checks a named subfolder in the Outlook Inbox ' (here the "Sales Reports" folder) for messages with attached ' files of a specific type (here file with an "xls" extension) ' and saves them to disk. Saved files are timestamped. The user ' can choose to view the saved files in Windows Explorer. ' NOTE: make sure the specified subfolder and save folder exist ' before running the macro. On Error GoTo SaveAttachmentsToFolder_err ' Declare variables Dim ns As NameSpace Dim inbox As MAPIFolder Dim SubFolder As MAPIFolder Dim Item As Object Dim Atmt As Attachment Dim FileName As String Dim i As Integer Dim varResponse As VbMsgBoxResult Set ns = GetNamespace("MAPI") Set inbox = ns.GetDefaultFolder(olFolderInbox) Set SubFolder = inbox.Folders("WhatsUp") ' Enter correct subfolder name. i = 0 ' Check subfolder for messages and exit of none found If SubFolder.Items.Count = 0 Then MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _ "Nothing Found" Exit Sub End If ' Check each message for attachments For Each Item In SubFolder.Items For Each Atmt In Item.Attachments ' Check filename of each attachment and save if it has "xls" extension If Right(Atmt.FileName, 3) = "pdf" Then ' This path must exist! Change folder name as necessary. FileName = "C:\test\" & _ Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName Atmt.SaveAsFile FileName i = i + 1 End If Next Atmt Next Item ' Show summary message If i > 0 Then varResponse = MsgBox("I found " & i & " attached files." _ & vbCrLf & "I have saved them into the C:\Email Attachments folder." _ & vbCrLf & vbCrLf & "Would you like to view the files now?" _ , vbQuestion + vbYesNo, "Finished!") ' Open Windows Explorer to display saved files if user chooses If varResponse = vbYes Then Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus End If Else MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" End If ' Clear memory SaveAttachmentsToFolder_exit: Set Atmt = Nothing Set Item = Nothing Set ns = Nothing Exit Sub ' Handle Errors SaveAttachmentsToFolder_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 SaveAttachmentsToFolder_exit End Sub
Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.