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.

Code:

---

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.

Code:

---

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

---

And this.

Code:

---

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

---

If you are renaming then the files should have the same extension so

Code:

---

    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

Code:

---

    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

---

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.

Code:

---

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

---

For the rest looking for the full working code, see below!

Code:

---

'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 following work in Outlook 2010

Code:

---

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"

Code:

---

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

---

Quote:

---

Originally Posted by bmarr21

For the rest looking for the full working code, see below!

Code:

---

'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?

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.

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\"

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?

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.

OK - I think the following changes should do it

Code:

---

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

---

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,

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.

Code:

---

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

---