Save All Outlook Attachments Selected Emails

This article shows you how to automatically save all attachments for the selected emails in Outlook with VBA into the designated folder.

Code:

Sub GetSelectedItems()
 Dim myOlExp As Outlook.Explorer
 Dim myOlSel As Outlook.Selection
 Dim oMail As Outlook.MailItem


 Dim MsgTxt As String
 Dim x As Long
 'Get senders of selected emails
 MsgTxt = "Senders of selected items:"
 Set myOlExp = Application.ActiveExplorer
 Set myOlSel = myOlExp.Selection
 For x = 1 To myOlSel.Count
 If myOlSel.Item(x).Class = OlObjectClass.olMail Then
 ' For mail item, use the SenderName property.
 'set the path for where the attachments will be saved
    strPath = "C:\Users\18622\OneDrive\Desktop\New Folder\"
    
    Set dicFileNames = CreateObject("Scripting.Dictionary")
    
    For Each individualItem In Application.ActiveExplorer.Selection
        If TypeName(individualItem) = "MailItem" Then
            For Each att In individualItem.Attachments
                If Not dicFileNames.exists(att.FileName) Then
                dicFileNames.Add att.FileName, 1
                Else
                dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
                End If
                
                att.SaveAsFile strPath & att.FileName
            Next att
        End If
    Next individualItem

 End If
 Next x
 Debug.Print MsgTxt
End Sub

Here's an alternative version (above video) if you want to create a folder for the count of the emails selected and place all attachments from each respective email into the current count folder (1, 2, 3, etc):

Sub GetSelectedItems()
 Dim myOlExp As Outlook.Explorer
 Dim myOlSel As Outlook.Selection
 Dim oMail As Outlook.MailItem

Dim i As Double
Dim ii As Double
Dim iii As Double
Dim iiii As Double

 Dim MsgTxt As String
 Dim x As Long
 'Get senders of selected emails
 MsgTxt = "Senders of selected items:"
 Set myOlExp = Application.ActiveExplorer
 Set myOlSel = myOlExp.Selection
 
 
 i = myOlSel.Count
 iii = 1
 iiii = 1
 
 For x = 1 To myOlSel.Count
 If myOlSel.Item(x).Class = OlObjectClass.olMail Then
 ' For mail item, use the SenderName property.
 'set the path for where the attachments will be saved

Set dicFileNames = CreateObject("Scripting.Dictionary")
   
      
    For Each individualitem In Application.ActiveExplorer.Selection
   
If TypeName(individualitem) = "MailItem" Then
      
    For Each att In individualitem.Attachments
             
             ii = individualitem.Attachments.Count
        
             strPath = "C:\Users\18622\OneDrive\Desktop\New Folder\" & iiii & "\"
                If Not dicFileNames.exists(att.FileName) Then
                dicFileNames.Add att.FileName, 1
                Else
                dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
                End If
                
                If iii = 1 Then
                MkDir "C:\Users\18622\OneDrive\Desktop\New Folder\" & iiii & "\"
                End If
                iii = iii + 1
                att.SaveAsFile strPath & att.FileName
            Next att
        End If
        
    iii = 1
    iiii = iiii + 1
    If iiii > i Then
    GoTo ending:
    End If
    Next individualitem
    
 End If
 Next x
ending:
End Sub

The below code takes all attachments out of the emails that you save down into a folder using the second program here. (The 2nd program basically will save down any attachment, or email containing attachments as a .msg, into a folder). This program emails all the attachments from only saved down emails containing attachments to an email address so that you can run my 2nd program again and get all the attachments.

Code REPLACE to " " with whatever email address that you want to send the emails to:

Sub FolderAndFileMacro()

Dim mypath As String
Dim myfile As String
Dim myfile2
Dim myextension As String
Dim wb As Workbook
Dim FldrPicker As FileDialog


Dim xx As Double

 Dim oFSO As Object
 Dim folder As Object
 Dim subfolders As Object
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 Set folder = oFSO.GetFolder("C:\Users\18622\OneDrive\Desktop\New folder\")
 Set subfolders = folder.subfolders
 xx = subfolders.count
 
 Set oFSO = Nothing
 Set folder = Nothing
 Set subfolders = Nothing
 'release memory

Dim x As Double

x = 1

Do Until x > xx






mypath = "C:\Users\18622\OneDrive\Desktop\New folder\" & x & "\"

'pull file names from Module 2 called GrabFilenamesfromFolder. It pulls the file names from the folder you select and set to mypath variable.
GrabFilenamesfromFolder (mypath)


erow = Range("A" & Rows.count).End(xlUp).Row
Range("B1").Select
ActiveCell.FormulaR1C1 = "=SEARCH("".msg"",RC[-1],1)"
Range("B1").Select
Selection.AutoFill Destination:=Range("B1" & ":" & "B" & erow), Type:=xlFillDefault
Columns("B").Select
Selection.Copy
Columns("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
 Columns("B").Select

 Selection.Replace What:="#VALUE!", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Dim counter As Double
counter = 1
      


'Target File Extension (must include wildcard "*")


'Loop through each Excel file in folder
Do Until counter > erow
line15:
If Range("B" & counter).Value <> 0 Then
myfile2 = Range("A" & counter).Value
counter = counter + 1
GoTo line11:
End If
counter = counter + 1
Loop
line11:
'Set variable equal to opened workbook


Dim objOL As Object
Dim Msg As Object
Set objOL = CreateObject("Outlook.Application")
inPath = mypath & myfile2
thisFile = Dir(inPath)
'Set Msg = objOL.CreateItemFromTemplate(thisFile)
Set Msg = objOL.Session.OpenSharedItem(inPath)
Msg.display
objOL.ActiveInspector.WindowState = olMaximized
' now use msg to get at the email parts
With Msg
.to = ""
.Subject = "Email"
.send
End With

Set objOL = Nothing
Set Msg = Nothing


      
 'add actions to do to this workbook
      
'switch back to workbook that has this macro
Workbooks("Open all Emails with attachments and forward them.xlsm").Activate
'close myfile

If counter <= erow Then
GoTo line15:
End If

Workbooks("Open all Emails with attachments and forward them.xlsm").Activate
Columns("A:B").Select
Selection.ClearContents
x = x + 1
Loop

End Sub

Sub GrabFilenamesfromFolder(path As String)
    Dim currentPath As String, directory As Variant
    Dim dirCollection As Collection
    Set dirCollection = New Collection
    Dim counter As Double
    counter = 1
    currentPath = Dir(path, vbDirectory)
    
    'Explore current directory
    Do Until currentPath = vbNullString
        Debug.Print currentPath
        'If Left(currentPath, 1) <> "." And _
            '(GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
            dirCollection.Add currentPath
        'End If
        currentPath = Dir()
        Range("A" & counter).Value = currentPath
        counter = counter + 1
    Loop
    
   
End Sub