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?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

NorieAnalyst Assistant Commented:
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
NorieAnalyst Assistant Commented:
Ermy

The code I posted would work with all highlighted/selected emails and you could run it from the Developer tab in Outlook.
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

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
NorieAnalyst Assistant Commented:
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
NorieAnalyst Assistant Commented:
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
NorieAnalyst Assistant Commented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Ermy WormyAuthor Commented:
Yes! Works perfectly. Thanks so much. Saves me so many hours.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.