Hi, I was looking for a macro code which would save attachments and save them with the email subject to a specific folder on my network. I have found this by Graham Major which is excellent and ideal for what I need.
Is it possible that it can be amended to check if the file name already exists and overwrite it with the latest email attachment?
Many Thanks
Sub Test()Dim olMsg As MailItem On Error Resume Next Set olMsg = ActiveExplorer.Selection.Item(1) Save_As_Subject olMsg lbl_Exit: Exit Sub End Sub Sub Save_As_Subject(olItem As MailItem) 'Graham Mayor - http://www.gmayor.com - Last updated - 13 Jan 2018 Dim olAttach As Attachment Dim strFileName As String Dim strExt As String Const strPath = "Y:\accounts\Conv slips\" 'the path to store the files For Each olAttach In olItem.Attachments strExt = Mid(olAttach.FileName, InStrRev(olAttach.FileName, Chr(46))) Select Case LCase(strExt) Case Is = ".docx", ".dotx", ".pdf", ".xlsx", ".zip", ".html", ".jpeg", ".txt", "xls", ".htm", ".doc" 'the wanted extensions strFileName = olItem.Subject strFileName = CleanFileName(strFileName) strFileName = strPath & strFileName & strExt olAttach.SaveAsFile strFileName Case Else End Select Next olAttach lbl_Exit: Set olItem = Nothing Set olAttach = Nothing Exit Sub End Sub Private Function CleanFileName(strFileName As String) As String 'Graham Mayor - http://www.gmayor.com - Last updated - 05 Jul 2017 'A function to ensure there are no illegal filename 'characters in a string to be used as a filename Dim arrInvalid() As String Dim vfName As Variant Dim lng_Name As Long Dim lng_Ext As Long Dim lngIndex As Long CleanFileName = strFileName 'Define illegal characters (by ASCII CharNum) arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|") 'Add the extension to the filename CleanFileName = CleanFileName 'Remove any illegal filename characters For lngIndex = 0 To UBound(arrInvalid) CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95)) Next lngIndex lbl_Exit: Exit Function End Function



Reply With Quote