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

[bmarr21]

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

[gmayor]

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

[bmarr21]

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

[bmarr21]

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

[gmayor]

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

[bmarr21]

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?

[gmayor]

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.

[bmarr21]

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

[gmayor]

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?

[bmarr21]

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.

[gmayor]

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

[davidarteaga]

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,

[gmayor]

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