Saving attachments from multiple emails and updating file name


New Member
Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
Let me start by saying that i am a VBA rookie and am trying to learn. I need to be able to download all attachments and embedded images from multiple emails in outlook and save them to a specified folder with a naming convention of Attachmentname_SubjectLine_Email Address_Date of Email. I was able to come across a code that solved 99% of the problem. The VBA script saves all attachments/embedded images and lets me select the destination to save. The only "issue" is that it saves the filename as the attachment name and for compliance reasons, I need it to reference the email, subject line and date of email. I would greatly appreciate any assistance that can be offered.

For additional information, I found the code here:

I attempted to embed the code, but I hit a character count limit. I am going to attach the full code to the post in a PDFdocument and include a snippet here:

                strFolderPath = CGPath(objFolder.Self.Path)
                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    lCountEachItem = objItem.Attachments.Count
                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments
                        ' /* Go through each attachment in the current item. */
                        For Each atmt In atmts
                            ' Get the full name of the current attachment.
                            strAtmtFullName = atmt.FileName
                            ' Find the dot postion in atmtFullName.
                            intDotPosition = InStrRev(strAtmtFullName, ".")
                            ' Get the name.
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                            ' Get the file extension.
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                            ' Get the full saving path of the current attachment.
                            strAtmtPath = strFolderPath & atmt.FileName
                            ' /* If the length of the saving path is not larger than 260 characters.*/
                            If Len(strAtmtPath) <= MAX_PATH Then
                                ' True: This attachment can be saved.
                                blnIsSave = True
                                ' /* Loop until getting the file name which does not exist in the folder. */
                                Do While objFSO.FileExists(strAtmtPath)
                                    strAtmtNameTemp = strAtmtName(0) & _
                                                      Format(Now, "_mmddhhmmss") & _
                                                      Format(Timer * 1000 Mod 1000, "000")
                                    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
                                    ' /* If the length of the saving path is over 260 characters.*/
                                    If Len(strAtmtPath) > MAX_PATH Then
                                        lCountEachItem = lCountEachItem - 1
                                        ' False: This attachment cannot be saved.
                                        blnIsSave = False
                                        Exit Do
                                    End If
                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then atmt.SaveAsFile strAtmtPath
                                lCountEachItem = lCountEachItem - 1
                            End If
                    End If
                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
            End If
            MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If
    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
        blnIsEnd = True
    End If
    SaveAttachmentsFromSelection = lCountAllItems
    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing
    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
End Function
Once again, this is not the full code and just a portion due to the character limit. Please see the attachment for the full code.

Thanks so much for any assistance you can offer!