Rename attachment with part of email subject

[leemcder]

Hi, I've been using this VBA code in outlook for a while and works great. My needs have now changed slightly. It takes a .XLS attachment and renames it with the subject and saves in a folder for me. Is it possible that this could rename the file with only part of the subject? I'll give you an example

Subject Incident Date: 12/02/2020, Our ref: 529098

The emails will come through like this (incident date and ref will always change) I only want it to rename the file Our ref: 529098

Is this possible?

Many thanks



Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim strName As String
saveFolder = "Y:\accounts\success fee bills\"
For Each objAtt In itm.Attachments
If Right(LCase(objAtt.FileName), 4) = ".xls" Then
strName = CleanFileName(itm.Subject & ".xls", ".xls")
objAtt.SaveAsFile saveFolder & strName
End If
Next objAtt
Set objAtt = Nothing
End Sub

Public Function CleanFileName(strFilename As String, strExtension As String) As String
'Graham Mayor
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strFilename is the filename to check
'strExtension is the extension of the file
Dim arrInvalid() As String
Dim vfName As Variant
Dim lng_Name As Long
Dim lng_Ext As Long
Dim lngIndex As Long
'Ensure there is no period included with the extension
strExtension = Replace(strExtension, Chr(46), "")
'Record the length of the extension
lng_Ext = Len(strExtension)
'Remove the path from the filename if present
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
Else
CleanFileName = strFilename
End If
'Remove the extension from the filename if present
If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
End If

'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 & Chr(46) & strExtension
'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

[gmayor]

Replace the first part with


Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim strSubject As String
Dim strName As String
strSubject = "Our Ref: " & Right(itm.Subject, Len(itm.Subject) - InStrRev(itm.Subject, Chr(32)))
saveFolder = "Y:\accounts\success fee bills\"
For Each objAtt In itm.Attachments
If Right(LCase(objAtt.fileName), 4) = ".xls" Then
strName = CleanFileName(strSubject & ".xls", ".xls")
objAtt.SaveAsFile saveFolder & strName
End If
Next objAtt
Set objAtt = Nothing
End Sub

[leemcder]

Thank you for this! I really appreciate it. I will give this a try when I'm back in the office. :)