View Single Post
 
Old 01-25-2023, 07:05 AM
JamesMWood JamesMWood is offline Windows 10 Office 2021
Novice
 
Join Date: May 2022
Posts: 25
JamesMWood is on a distinguished road
Default

I got this working, but it only works by forwarding the draft/creating another copy of the draft email. Can it be tweaked so it does it with the existing/original draft instead?

Sub RenameAttachmentsWhenForwarding()
Dim olItem As MailItem
Dim Att As Attachment
Dim Atts As Attachments
Dim olForward As MailItem
Dim FWAtt As Attachment
Dim FWAtts As Attachments
Dim FSO As Object
Dim TempFPath As Object
Dim FilePath As String
Dim strName As String
Dim strExten As String
Dim strFile As String

Set olItem = Application.ActiveInspector.CurrentItem
Set Atts = olItem.Attachments
Set olForward = olItem.Forward
olForward.Display

On Error Resume Next

For Each Att In Atts
'Get the path to Temporary Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TempFPath = FSO.GetSpecialFolder(2)
FilePath = TempFPath.Path & ""

'Rename the attachments
strName = Replace(Att.FileName, "%20", " ")
'Change "4" based on the length of the attachment file extension
strExten = Right(Att.FileName, 4)
'strFile = FilePath & strName & "." & strExten
strFile = FilePath & strName

If strName <> "" Then
'Save the attachments to the Temporary Folder
Att.SaveAsFile (strFile)

'Add the attachments saved in new names from the Temporary Folder
olForward.Attachments.Add (strFile)
Set FWAtts = olForward.Attachments

'Remove the original attachments
For Each FWAtt In FWAtts
If InStr(FWAtt.FileName, Att.FileName) > 0 Then
FWAtt.Delete
End If
Next
End If
Next
End Sub
Reply With Quote