Save Email Attachments with Received Time and Sender Name

Hi Everyone,

Goal: My goal is to have a macro that saves all emails attachments to a specific folder on emails that I have selected in my Outlook.

What I have tried: I have code, see below, that works great but....when I have multiple attachments with the same file name the macro only saves one of the attachments. For example, I will have multiple attachments called "image.pdf" but it only saves one attachment with that name and file type. I have been researching this for weeks and have tried a few different methods but none have worked for my needs or worked at all.

Microsoft Version: Outlook 365

How my code works: How my code works is it saves email attachments to a specific folder on emails that I have selected in Outlook. It involves two macros. The macro called "Save_Emails_TEST" finds the folder I have designated and then calls on the "SaveAttachments" macro that actually saves the attachments.

My request is this. Can someone please help me add code to my existing code. I would like this code to add the received date and time, senders' name, and original file name as the new file name for the files that are saved in my external folder.

Thank you in advance!
Ryan

Code:

---

Public Sub Save_Emails_TEST()strFolderpath = "H:\Saved Email Attachments\Test"
SaveAttachments
End Sub

Private Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
On Error Resume Next
Set objOL = Application
Set objSelection = objOL.ActiveExplorer.Selection
' Check each selected item for attachments.
For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.count
    If lngCount > 0 Then
        ' Use a count down loop for removing items from a collection. Otherwise, the loop counter gets _
        confused and only every other item is removed.
        For i = lngCount To 1 Step -1
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName
            ' Combine with the path to the folder.
            strFile = strFolderpath & strFile
            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
        Next I
    End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

---

The following will add the name and time, however that creates problems of its own because of illegal filename characters, so the date and time should be formatted as "yyyyMMdd_hhmm"and the sender name must be checked to eliminate illegal characters. Note also that the path should be terminated with the folder separator character and must exist unless you add code to create it if missing.

Code:

---

Option Explicit

'Updated 22 July 2021 by Graham Mayor - https://www.gmayor.com

Public Sub SaveAttachments()
Const strFolderpath As String = "H:\Saved Email Attachments\Test\"

Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
    On Error Resume Next
    Set objOL = Application
    Set objSelection = objOL.ActiveExplorer.Selection
    ' Check each selected item for attachments.
    For Each objMsg In objSelection
        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count
        If lngCount > 0 Then
            ' Use a count down loop for removing items
            ' from a collection. Otherwise, the loop counter gets
            ' confused and only every other item is removed.
            For i = lngCount To 1 Step -1
                ' Get the file name and add received time and sender name.
                strFile = Format(objMsg.ReceivedTime, "yyyyMMdd_hhmm") & _
                          "_" & objMsg.SenderName & _
                          "_" & objAttachments.Item(i).FileName
                'Remove illegal filename characters
                strFile = CleanFileName(strFile)
                ' Combine with the path to the folder.
                strFile = strFolderpath & strFile
                objAttachments.Item(i).SaveAsFile strFile
            Next i
        End If
    Next
ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub

Private Function CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
    'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    'Remove any illegal filename characters
    CleanFileName = strFileName
    For lng_Index = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
    Next lng_Index
lbl_Exit:
    Exit Function
End Function

---

Gmayor, I have seen your work throughout this forum and I was really really hoping you would be the one to help me because if anyone could solve my problem I knew it would be you! IT WORKS PEREFECTLY! How much time did this take you to make this code? I would like to make a donation to your website for your help and time.

I really appreciate and admire your work. You clearly know what you are doing. Could you recommend any tips, books, resources, or websites that could help someone like me learn VBA coding better? I don't have any computer programing education. I have an accounting background. I am self-taught in VBA thus far. I use VBA forums to try and learn but it’s not as structured as I would like. Basically, I understand enough VBA code to be dangerous haha.

Again, I appreciate your help Gmayor!

Thanks for your appreciation. There are plenty of coding examples on my web site and that of my friend Greg Maxey. Others I will let you discover for yourself :)