Outlook VBA Save Email Attachments with Received Time and Sender Name

AlbinoRyno88

New Member
Joined
Dec 14, 2017
Messages
1
Hi Everyone,

I have some VBA code that I found on the internet that I have been using and works great. I'm sorry if this question has been asked already but I have been researching it for weeks and it seems like there are multiple ways to do this and not all work with my code.

I use the VBA code below in Outlook. How the code works is it saves email attachments to a specific folder on emails that I have selected in Outlook. The problem that I am running into is that macro doesn't pick up attachments with the same name. For example, I will have multiple attachments called "image.pdf" but it only saves one attachment with that name and file type. I'm thinking if I can add the Received Date and Time as well as the Sender's Name to the file name it would help make the file name unique and would save all the attachments. However, when I try this with code I think will work I get errors.

Below is the code I am using. 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 the received date and time, senders' name, and original file name as the new file name that is saved in my folder?

Thank you in advance!
Ryan

VBA 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
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Hi @AlbinoRyno88, welcome to MrExcel.

Not exactly according to your request, but because of:
... it would help make the file name unique and would save all the attachments.
you might be interested in the code below. It adds a numeric suffix in case of duplicate file names, e.g.:
image.jpg
image(1).jpg
image(2).jpg
image(3).jpg
... and so on.

VBA Code:
Public Function AddSuffix(ByVal argFileName As String) As String
    
    Dim oFSO As Object, lPos As Long, sFile As String, sResult As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sResult = argFileName

    lPos = InStrRev(sResult, ".")
    If lPos = 0 Then
        sResult = UpdateFileSuffix(sResult)
    Else
        sFile = Left(sResult, lPos - 1)
        If Len(sFile) = 0 Then
            sFile = UpdateFileSuffix(sResult)
        Else
            sFile = UpdateFileSuffix(sFile)
        End If
        sResult = sFile & "." & Right(sResult, Len(sResult) - lPos)
    End If
    If oFSO.FileExists(sResult) Then
        AddSuffix = AddSuffix(sResult)
    Else
        AddSuffix = sResult
    End If
End Function


Public Function UpdateFileSuffix(ByVal argFileName As String) As String

    Dim sSfx As String, lPos As Long

    If Not argFileName Like "*(*)" Then
        UpdateFileSuffix = argFileName & "(1)"
    Else
        lPos = InStrRev(argFileName, "(") + 1
        sSfx = Mid(argFileName, lPos, Len(argFileName) - lPos)
        If IsNumeric(sSfx) Then
            UpdateFileSuffix = Left(argFileName, lPos - 1) & (CLng(sSfx) + 1) & ")"
        Else
            UpdateFileSuffix = argFileName & "(1)"
        End If
    End If
End Function


This AddSuffix function takes an argument (a file name) and returns that name with a suffix. This function is dependent on the separate UpdateFileSuffix function. To be able to use the AddSuffix function, I have slightly modified your code. In addition, I modified the header of your method so that it also expects an argument. Changes are in red.
Hopefully this is of some help.

Rich (BB code):
Public Sub Save_Emails_TEST()
    strFolderPath = "H:\Saved Email Attachments\Test\"
    SaveAttachments strFolderPath
End Sub


Private Sub SaveAttachments(ByVal argFolderPath As String)

    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

    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    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 = argFolderPath & strFile

                ' take duplicate file names into account
                If oFSO.FileExists(strFile) Then
                    strFile = AddSuffix(strFile)
                End If

                ' 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
 
Upvote 0
Dears,

I'm bringing up this thread instead of opening a new one.
I'm successfully saving Outlook attachments with the below code, which is really similar to the above one and it takes into account possible duplicates.

Is there any way to save the attachments with the sender name too? I've done some test without success.

VBA Code:
'---------------------------------------------------------------------------------
' The sample scripts are not supported under any Microsoft standard support
' program or service. The sample scripts are provided AS IS without warranty
' of any kind. Microsoft further disclaims all implied warranties including,
' without limitation, any implied warranties of merchantability or of fitness for
' a particular purpose. The entire risk arising out of the use or performance of
' the sample scripts and documentation remains with you. In no event shall
' Microsoft, its authors, or anyone else involved in the creation, production, or
' delivery of the scripts be liable for any damages whatsoever (including,
' without limitation, damages for loss of business profits, business interruption,
' loss of business information, or other pecuniary loss) arising out of the use
' of or inability to use the sample scripts or documentation, even if Microsoft
' has been advised of the possibility of such damages.
'---------------------------------------------------------------------------------

Option Explicit

' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr
    
    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
    
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
    ' The window handle of Outlook.
    Private lHwnd As Long
    
    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If

' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260

' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderPath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.
    Dim sender As String
    
    
    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0
    
    On Error Resume Next
    
    Set selItems = ActiveExplorer.Selection
    
    If Err.Number = 0 Then
        
        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)
        
        If lHwnd <> 0 Then
            
            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
            
            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
                       Err.Description & ".", vbCritical, "Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If
            
            If objFolder Is Nothing Then
                strFolderPath = ""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                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) 'removed
                                    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 'removed
                                    End If
                                'Loop 'removed
                                
                                ' /* Save the current attachment if it is a valid file name. */
                                If blnIsSave Then atmt.SaveAsFile strAtmtPath
                            Else
                                lCountEachItem = lCountEachItem - 1
                            End If
                        Next
                    End If
                    
                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
            End If
        Else
            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. */
    Else
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
        blnIsEnd = True
    End If
    
PROC_EXIT:
    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

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim lNum As Long
    
    lNum = SaveAttachmentsFromSelection
    
    If lNum > 0 Then
        MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
End Sub

Thanks a lot,
D
 
Upvote 0
You can use the SenderName property for that. My suggested change to the code you posted does not take into account any characters that are invalid for use in a filename.
For example, you could change this snippet of the code as follows.

Before:
Rich (BB code):
strAtmtNameTemp = strAtmtName(0) & _
                  Format(Now, "_mmddhhmmss") & _
                  Format(Timer * 1000 Mod 1000, "000")

After:
Rich (BB code):
strAtmtNameTemp = strAtmtName(0) & _
                  "_(" & objItem.SenderName & ")_" & _
                  Format(Now, "_mmddhhmmss") & _
                  Format(Timer * 1000 Mod 1000, "000")
 
Upvote 0
Hi GWteB,

Thanks a lot for the suggestion. Invalid characters should be quite impossible in my case, but thanks for highlighting this.

KR,
D
 
Upvote 0
You're welcome & thanks for the feedback (y)
 
Upvote 0

Forum statistics

Threads
1,223,897
Messages
6,175,271
Members
452,628
Latest member
dd2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top