VBA Outlook 2016: Save attachments of selected emails to a specified folder, If duplicate change name.

Hi, I've been searching for a macro that does the following but can't seem to find one that works without a rule --> "run script", and works for Outlook 2016:

Needs to:
1. Save attachments of all selected (highlighted) emails to a predefined folder (ex: C:\Users\...etc)
2. There are many duplicates, so change name of duplicate to File name + i.
3. Not delete the attachments from the email after saving.

I hope this is possible!!
Ermy WormyAsked:
Who is Participating?
 
NorieConnect With a Mentor VBA ExpertCommented:
Hopefully this will sort it.
Sub SaveAttachmentsFromSelectedMailItems()
Dim individualItem As Object
Dim att As Attachment
Dim strPath As String
Dim strFileName As String
Dim strExt As String
Dim dicFileNames As Object

    strPath = "C:\Users\CIDChecker\Test\"
    
    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
                
                strFileName = Split(att.FileName, ".")(0)
                strExt = Split(att.FileName, ".")(1)
                
                att.SaveAsFile strPath & strFileName & "-" & dicFileNames(att.FileName) & "." & strExt
                
            Next att
        End If
    Next individualItem
    
End Sub

Open in new window

1
 
NorieConnect With a Mentor VBA ExpertCommented:
Ermy

How would you want this to be executed?

Here's code to save all the attachments from all the selected emails.
Sub SaveAttachmentsFromSelectedMailItems()
Dim individualItem As Object
Dim att As Attachment
Dim strPath As String

    strPath = "C:\Users\TestUser\Test\"
    
    For Each individualItem In Application.ActiveExplorer.Selection
        If TypeName(individualItem) = "MailItem" Then
            For Each att In individualItem.Attachments
                att.SaveAsFile strPath & att.FileName
            Next att
        End If
    Next individualItem
    
End Sub

Open in new window

0
 
Ermy WormyAuthor Commented:
Norie,

If at all possible (I am a complete novice so bear with me) highlight emails, run macro.

If not, I can work with it applying to all emails in the inbox.
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

 
NorieVBA ExpertCommented:
Ermy

The code I posted would work with all highlighted/selected emails and you could run it from the Developer tab in Outlook.
0
 
Ermy WormyAuthor Commented:
Thanks! That works for the first files. However, most of the files I want to save have the same file name, so it will just overwrite them. Is it possible to get it to add a unique number to the file name if a duplicate is detected?
0
 
NorieVBA ExpertCommented:
I was just working on that, give this a try.
Sub SaveAttachmentsFromSelectedMailItems()
Dim individualItem As Object
Dim att As Attachment
Dim strPath As String
Dim dicFileNames As Object

    strPath = "C:\Users\CIDChecker\Test\"
    
    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 & "-" & dicFileNames(att.FileName)
            Next att
        End If
    Next individualItem
    
End Sub

Open in new window

0
 
Ermy WormyAuthor Commented:
Awesome! Saves all the attachments.

Slight problem: the File type also changes to a PDF-1 / PDF-2 / PDF-etc File.

So I'd have to go through all the numbers once I want to open it and set a default program to open each new number.

But this will work!
0
 
NorieVBA ExpertCommented:
Oops, I see what you mean.

When I tested the code I was wondering why I wasn't getting the usual icons for Word, PDF etc. files.

Give me a minute and I'll sort it out.
1
 
Ermy WormyAuthor Commented:
Yes! Works perfectly. Thanks so much. Saves me so many hours.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.