There are situations when you would like to save all attachments from an email ID to a particular folder. Outlook do not have any ready feature to do it. A Simple macro can do the trick for you. No worries, if you have not ever developed or used a macro.If you are not familiar with Outlook macro or do not know how start with it, Here is an article which will quickly on-board you on macro world : Getting started with Outlook Macro
This article will guide you through the VBA macro code that can be used to accomplish saving of attachment from multiple selected emails.
If you are interested in the macro itself, you may skip to the codes and copy those codes. If your interest is academic, like you want to learn more about it, then you may continue reading
How to use save attachment vba macro code
- Open To start with writing macro, we need to open Visual Basic editor window. You can press “Alt + F11” key buttons to open Visual Basic editor window.
- Then please insert a module
- Copy code from GetOutputDirectory()
- Paste copied codes to the new module you have inserted in step 2
- Copy code from SaveAttachments()
- Paste copied codes after the code in step 4 and save it
- Right click on empty place within quick access toolbar and select customize Quick Access Toolbar
- Next, select Macros from the Choose commands from
- Then, in the macro list, choose a macro
- After that, click Add button in center
- Finally, click OK
VBA code for GetOutputDirectory()
First thing first. We need to figure out where to store the attachments. It will be nice to let user decide it, instead of making it hard coded. The Function GetOutputDirectory() does the same thing. It interacts with user to get the destination directory and returns that. We are using windows shell function to do this. The parameter that we pass to the function determines what value we retrieve from the function and what folder we start while browsing. Feel free to change it. You will find details on how to change the behavior in the following link
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44
Public Function GetOutputDirectory() As String Dim retval As String 'Return Value Dim sMsg As String Dim cBits As Integer Dim xRoot As Integer Dim oShell As Object Set oShell = CreateObject("shell.application") sMsg = "Select a Folder To Output The Attachments To" cBits = 1 xRoot = 17 On Error Resume Next Dim oBFF Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot) If Err Then Err.Clear GetOutputDirectory = "" Exit Function End If On Error GoTo 0 If Not IsObject(oBFF) Then GetOutputDirectory = "" Exit Function End If If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then retval = "" Else retval = oBFF.Self.path 'Make sure there's a \ on the end If Right(retval, 1) <> "\" Then retval = retval + "\" End If End If GetOutputDirectory = retval End Function
VBA macro code for SaveAttachments()
This is the main part of the program, where it iterates through each mail items in the selection to find out if there is any attachments. If there are attachments, then it will prompt user with a suggested name. Same name can be used or it can changed. This will also check if a file already exists in the directory. In case it finds one, it will give an option to change it.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
Public Sub SaveAttachments() 'Note, this assumes you are in the a folder with e-mail messages when you run it. 'It does not have to be the inbox, simply any folder with e-mail messages Dim App As New Outlook.Application Dim Exp As Outlook.Explorer Dim Sel As Outlook.Selection Dim AttachmentCnt As Integer Dim AttTotal As Integer Dim MsgTotal As Integer Dim outputDir As String Dim outputFile As String Dim fileExists As Boolean Dim cnt As Integer Dim strSubject As String 'Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL) Dim fso As FileSystemObject Set Exp = App.ActiveExplorer Set Sel = Exp.Selection Set fso = New FileSystemObject outputDir = GetOutputDirectory() If outputDir = "" Then MsgBox "You must pick an directory to save your files to. Exiting SaveAttachments.", vbCritical, "SaveAttachments" Exit Sub End If 'Loop thru each selected item in the inbox For cnt = 1 To Sel.Count 'If the e-mail has attachments... If Sel.item(cnt).Attachments.Count > 0 Then MsgTotal = MsgTotal + 1 'For each attachment on the message... For AttachmentCnt = 1 To Sel.item(cnt).Attachments.Count 'Get the attachment Dim att As Attachment Set att = Sel.item(cnt).Attachments.item(AttachmentCnt) outputFile = att.FileName 'Forcing to give me option to choose file name Let strSubject = Sel.item(cnt).SentOn & vbCrLf & Sel.item(cnt).Subject & vbCrLf & "( From " & Sel.item(cnt).SenderName & " )" outputFile = InputBox(strSubject & vbCrLf & vbCrLf & "Please enter a new name if needed, or hit cancel to skip this one file.give name cancel to exit", "File Name", outputFile) If outputFile = "" Then 'Exit leaving fileexists true. That will be a flag not to write the file GoTo nextitem End If 'Give an option to exit If outputFile = "cancel" Then GoTo earlyexit End If fileExists = fso.fileExists(outputDir + outputFile) Do While fileExists = True outputFile = InputBox("The file " + outputFile _ + " already exists in the destination directory of " _ + outputDir + ". Please enter a new name, or hit cancel to skip this one file.", "File Exists", outputFile) 'If user hit cancel If outputFile = "" Then 'Exit leaving fileexists true. That will be a flag not to write the file Exit Do End If fileExists = fso.fileExists(outputDir + outputFile) Loop 'Save it to disk if the file does not exist If fileExists = False Then att.SaveAsFile (outputDir + outputFile) AttTotal = AttTotal + 1 End If nextitem: Next End If Next earlyexit: 'Clean up Set Sel = Nothing Set Exp = Nothing Set App = Nothing Set fso = Nothing 'Let user know we are done Dim doneMsg As String doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages." MsgBox doneMsg, vbOKOnly, "Save Attachments" Exit Sub ErrorHandler: Dim errMsg As String errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description Dim errResult As VbMsgBoxResult errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments") Select Case errResult Case vbAbort Exit Sub Case vbRetry Resume Case vbIgnore Resume Next End Select End Sub
These codes are from my archive. I had collected it from internet long long ago and then had modified to my needs. when I look back, I do not see those old urls are live anymore.