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