VBA Macro to Save attachments from multiple selected emails in outlook

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

Shell.browseForFolder method

GetOutputDirectory()

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.

SaveAttachments()

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.