Consulting

Results 1 to 13 of 13

Thread: Outlook download attachments - Multi Files Specific Name / Specific types - VBA macro

  1. #1
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location

    Outlook download attachments - Multi Files Specific Name / Specific types - VBA macro

    Outlook 2013

    Over a week reading similar codes and still cant pinpoint this, help greatly appreciated!

    -Main problem it only renames the first attachment and i have no control over the other items in the email.


    This code saves my attachment where I want, and renames it what I want. It works perfectly IF the email has only one attachment and no images in signature. If the email comes with one excel file and an image in signature, it renames the image what I intended to be the excel file name, and then leaves the excel file its original name.

    Would be awesome if I can also dictate specific extensions for it to include in the download.

    Public Sub saveAttachtoDisk_Vendor(itm As Outlook.MailItem)
    
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim fso As Object
    Dim oldName
    
    Dim file As String
    Dim DateFormat As String
    Dim newName As String
    
    Dim enviro As String
    saveFolder = "S:\Test\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    
     For Each objAtt In itm.Attachments
     file = saveFolder & objAtt.DisplayName
     objAtt.SaveAsFile file
    
     Set oldName = fso.GetFile(file)
     DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
     newName = "Vendor.xls"
     oldName.Name = newName
    
     Set objAtt = Nothing
     Next
    
     Set fso = Nothing
     End Sub

    I am toying with these codes from other scripts but cant seem to get them to work right, I am novice at the language.

    validExtString = ".doc .docx .xls .xlsx .msg .pdf .txt" ' <---- Update as needed
    validExtArray = Split(validExtString, " ")
    And this.

    If Right(atmt.FileName, 3) = "xls" Then
         FileName = "C:\Email Attachments\" & atmt.FileName
         atmt.SaveAsFile FileName
         i = i + 1
    End If

  2. #2
    If you are renaming then the files should have the same extension so
        For Each objAtt In itm.Attachments
            If Right(LCase(objAtt.Filename), 4) = ".xls" Then
                file = saveFolder & objAtt.Filename
                objAtt.SaveAsFile file
                Set oldName = fso.GetFile(file)
                DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
                newName = "Vendor.xls"
                oldName.Name = newName
            End If
            Set objAtt = Nothing
        Next
    You could simply save the required worksheet with the chosen name in the firstplace (and process different extensions by type) e.g. as follows. The DateFormat seems superfluous as the times associated with the file will be the current time and date

        For Each objAtt In itm.Attachments
            Select Case Right(LCase(objAtt.Filename), 4)
                Case ".xls": objAtt.SaveAsFile saveFolder & "Vendor.xls"
                Case "xlsx": objAtt.SaveAsFile saveFolder & "Vendor.xlsx"
                Case "xlsm": objAtt.SaveAsFile saveFolder & "Vendor.xlsm"
                Case Else
            End Select
            Set objAtt = Nothing
        Next
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location
    Thanks so much, the first one did the trick!!! Much appreciated, I spent hours pulling my hair out on this.. The second suggestion I could not get to work, not needed now but I am curious if you can think of why? I have an itch to understand.. I put the second one in the same way I did the first but zero files saved.

    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
     
     
        For Each objAtt In itm.Attachments
            Select Case Right(LCase(objAtt.FileName), 4)
                Case ".xls": objAtt.SaveAsFile saveFolder & "Vendorxls.xls"
                Case "xlsx": objAtt.SaveAsFile saveFolder & "Vendor.xlsx"
                Case "xlsm": objAtt.SaveAsFile saveFolder & "Vendor.xlsm"
                Case Else
            End Select
            Set objAtt = Nothing
        Next
     
        
     'For Each objAtt In itm.Attachments
     'file = saveFolder & objAtt.DisplayName
     'objAtt.SaveAsFile file
      
     'Set oldName = fso.GetFile(file)
     'DateFormat = Format(oldName.DateLastModified, "yyyy-mm-dd ")
     ''newName = objAtt.DisplayName
     'newName = "Vendor.xls"
     'oldName.Name = newName
     
     'Set objAtt = Nothing
     'Next
       
     Set fso = Nothing
     End Sub

  4. #4
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location
    For the rest looking for the full working code, see below!




    'This will only download a file that is xls!
    'And it can be set to be used with a rule in outlook.
    
    Public Sub saveAttachtoDisk_Vendor(itm As Outlook.MailItem)
    
     
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim fso As Object
    Dim oldName
     
    Dim file As String
    Dim DateFormat As String
    Dim newName As String
     
    Dim enviro As String
    
    ' Change this to the folder path you want the file to be in.
    saveFolder = "S:\Test\"
     
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
     
     
        For Each objAtt In itm.Attachments
        ' set the last 4 charachters to the file you are looking for, in this example it is '.xls'
            If Right(LCase(objAtt.FileName), 4) = ".xls" Then
                file = saveFolder & objAtt.FileName
                objAtt.SaveAsFile file
                Set oldName = fso.GetFile(file)
                newName = "Vendor.xls"
                oldName.Name = newName
            End If
            Set objAtt = Nothing
        Next
     
       
     Set fso = Nothing
     End Sub

  5. #5
    The following work in Outlook 2010
    Public Sub saveAttachtoDisk_VendorA(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
        saveFolder = "S:\Test\"
        For Each objAtt In itm.Attachments
            Select Case Right(LCase(objAtt.Filename), 4)
                Case ".xls": objAtt.SaveAsFile saveFolder & "Vendor.xls"
                Case "xlsx": objAtt.SaveAsFile saveFolder & "Vendor.xlsx"
                Case "xlsm": objAtt.SaveAsFile saveFolder & "Vendor.xlsm"
                Case ".doc": objAtt.SaveAsFile saveFolder & "Vendor.doc"
                Case "docx": objAtt.SaveAsFile saveFolder & "Vendor.docx"
                Case "docm": objAtt.SaveAsFile saveFolder & "Vendor.docm"
                Case "dotm": objAtt.SaveAsFile saveFolder & "Vendor.dotm"
                Case ".pdf": objAtt.SaveAsFile saveFolder & "Vendor.pdf"
                Case ".zip": objAtt.SaveAsFile saveFolder & "Vendor.zip"
                Case Else
            End Select
        Next objAtt
    lbl_Exit:
        Set objAtt = Nothing
        Exit Sub
    End Sub
    The problem is that when you have multiple files all saving with potentially the same name, the subsequent saves will overwrite the originals. This is probaably OK when dealing with single files, but you will overwrite wanted files otherwise. You therefore need code to correct that. The following version will not overwrite existing filenames, but will append an incrementing number in brackets e.g. "Vendor(1).ext"

    Option Explicit
    Public Sub saveAttachtoDisk_VendorB(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim strExt As String
    Dim strName As String
        saveFolder = "S:\Test\"
        For Each objAtt In itm.Attachments
            strExt = Mid$(LCase(objAtt.Filename), InStrRev(LCase(objAtt.Filename), Chr(46)) + 1)
            strName = "Vendor" & strExt
            strName = FileNameUnique(saveFolder, strName, strExt)
            objAtt.SaveAsFile saveFolder & strName
        Next objAtt
    lbl_Exit:
        Set objAtt = Nothing
        Exit Sub
    End Sub
    
    Private Function FileNameUnique(strPath As String, _
                                   strFileName As String, _
                                   strExtension As String) As String
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName) - (Len(strExtension))
        strFileName = Left(strFileName, lngName)
        Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function FileExists(filespec) As Boolean
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  6. #6
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location
    Quote Originally Posted by bmarr21 View Post
    For the rest looking for the full working code, see below!




    'This will only download a file that is xls!
    'And it can be set to be used with a rule in outlook.
    
    Public Sub saveAttachtoDisk_Vendor(itm As Outlook.MailItem)
    
     
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    Dim fso As Object
    Dim oldName
     
    Dim file As String
    Dim DateFormat As String
    Dim newName As String
     
    Dim enviro As String
    
    ' Change this to the folder path you want the file to be in.
    saveFolder = "S:\Test\"
     
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
     
     
        For Each objAtt In itm.Attachments
        ' set the last 4 charachters to the file you are looking for, in this example it is '.xls'
            If Right(LCase(objAtt.FileName), 4) = ".xls" Then
                file = saveFolder & objAtt.FileName
                objAtt.SaveAsFile file
                Set oldName = fso.GetFile(file)
                newName = "Vendor.xls"
                oldName.Name = newName
            End If
            Set objAtt = Nothing
        Next
     
       
     Set fso = Nothing
     End Sub

    The code has the following flaw:
    If there is no file in teh save folder to match the newName = "Vendor.xls - Then it will save properly as Vendor.xls, good.
    Once that file is in that folder, it will save the attachment as the original file name (it wont rename it) Bad
    Then each subsequent save will overwrite the original file name continuously. I want this to happen with the Vendor.xls name, but it overwrites the original filename instead.
    The intended file name in this macro, Vendor.xls, never gets written more than the first time. Any help here?

  7. #7
    I already provided a function that will rename the file if the file exists and demonstrated how to call it. Your 'full working code' does not use that function.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  8. #8
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location
    Thanks I got that working, I was actually just thrown off from the modified date assuming each time would change the date in my test even though the file was the same, fail on my part.

    I have another question though, is it possible to set two different save locations for these files? I am able to have two diff scripts to work around, but just curious if we can shorten it to one.

    saveFolder = "S:\Test\"

  9. #9
    You can have the files saved in any location you have write access to. What determines which folder you want to save into, or do you want to save all files in two folders?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  10. #10
    VBAX Regular
    Joined
    Mar 2015
    Posts
    8
    Location
    I want to save the file twice, in two different locations. I can just make two subs with diff paths and have them both called, but wondering if there was a way to specify this in the one code.

  11. #11
    OK - I think the following changes should do it

    Public Sub saveAttachtoDisk_VendorB(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Const saveFolder As String = "S:\Test\"
    Const saveFolder2 As String = "C:\Path\" 'The second folder
    Dim strExt As String
    Dim strName As String
        For Each objAtt In itm.Attachments
            strExt = Mid$(LCase(objAtt.Filename), InStrRev(LCase(objAtt.Filename), Chr(46)) + 1)
            strName = "Vendor" & strExt
            strName = FileNameUnique(saveFolder, strName, strExt)
            objAtt.SaveAsFile saveFolder & strName
            strName = FileNameUnique(saveFolder2, strName, strExt) 'Check the second folder
            objAtt.SaveAsFile saveFolder2 & strName 'Save again in the second folder
        Next objAtt
    lbl_Exit:
        Set objAtt = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  12. #12
    Hey Gmayor,

    Can you assist me with this script

    I have this compiled.

    Public Sub NICEE(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim saveFolder As String
    saveFolder = "R:\BP\PUJ\Paradisus Melia Caribe Beach\Historical"
    Dim saveFolder_2 As String
    saveFolder_2 = "R:\BP\PUJ\Paradisus Melia Caribe Beach\Master"
    For Each objAtt In itm.Attachments
    Select Case Left(UCase(objAtt.FileName), 3)
    Case "MCB": objAtt.SaveAsFile saveFolder & "MCB BP " & Format(Now(), "MM-DD-YYYY") & ".xls"
    Case "MCB": objAtt.SaveAsFile saveFolder_2 & "MPC BP MASTER .xls"
    Case "MPC": objAtt.SaveAsFile saveFolder & "MPC BP " & Format(Now(), "MM-DD-YYYY") & ".xls"
    Case Else
    End Select
    Next objAtt
    lbl_Exit:
    Set objAtt = Nothing
    Exit Sub
    End Sub

    But I guess because im using the same Case it doesnt duplicate saving it the idea is for it to save one as a historical and the other to save over a Master excel file so it can update everytime i recieve the email the rule will go against.

    Hope you can help me.

    Many Thanks,
    Last edited by davidarteaga; 06-27-2019 at 05:46 PM.

  13. #13
    This is an old thread - you should have created a new one!

    It doesn't duplicate because your case statements only have one action and only the first matching case is used. You need something like the following which will work as long as you only have one such message a day. In more than one see the thread for code to make the names unique.
    Public Sub NICEE(itm As Outlook.MailItem)Dim objAtt As Outlook.Attachment
    Const saveFolder As String = "R:\BP\PUJ\Paradisus Melia Caribe Beach\Historical\"
    Const saveFolder_2 As String = "R:\BP\PUJ\Paradisus Melia Caribe Beach\Master\"
        For Each objAtt In itm.Attachments
            Select Case Left(UCase(objAtt.fileName), 3)
                Case "MCB"
                    objAtt.SaveAsFile saveFolder & "MCB BP " & Format(Now(), "MM-DD-YYYY") & ".xls"
                    objAtt.SaveAsFile saveFolder_2 & "MCB BP MASTER.xls"
                Case "MPC"
                    objAtt.SaveAsFile saveFolder & "MPC BP " & Format(Now(), "MM-DD-YYYY") & ".xls"
                    objAtt.SaveAsFile saveFolder_2 & "MPC BP MASTER.xls"
                Case Else
            End Select
        Next objAtt
    lbl_Exit:
        Set objAtt = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •