Save and Rename Outlook Email Attachments

[Gazmoz17]

Hi,

I'm struggling with the code its returning an error?

Save and Rename Outlook Email Attachments

Use a macro to save attachments on Outlook email messages to a folder on your hard drive and add the files last modified date to the filename.

www.slipstick.com

My code:

Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim strSubject As String, strExt As String
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
saveFolder = enviro & "C:\Users\john\Documents\Touch Portal Backups\20210616-170520"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection

For Each itm In Selection
For Each objAtt In itm.Attachments
' get the last 5 characters for the file extension
strExt = Right(objAtt.DisplayName, 5)
' clean the subject
strSubject = itm.Subject
ReplaceCharsForFileName strSubject, "-"

' put the name and extension together
file = saveFolder & strSubject & strExt

objAtt.SaveAsFile file
Next
Next

Set objAtt = Nothing
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub

Error line in red.

Any help much appreicated.

Thanks
Gareth