Delete specific att and forward message

[Erka]

Hi,

I have to forward e-mails every day, which always contain two attachments.
I always have to delete one of the attachments and only then can I forward it.


I'm looking for a macro that can do this automatically.


Of two attachments (pdf), one always starts with 'invoice_' followed by a random number. The second PDF always starts with 'detailinfo_' and a random number.
I am not a vba expert. My current code is based on the internet and my own modifications.
The code works except for one point, it removes detailinfo_*.pdf from the original message and not from the email to be sent. The original message should just stay as it is.

my code:

Sub DelAttAndForward()
'
Dim xFileSystemObj, xShellApp As Object
Dim xNameSpace, xNameSpaceItem, xItem As Object
Dim xTempFldPath, xFilePath As String
Dim xSelItems As Outlook.Selection
Dim xFWItems As Outlook.Selection
Dim xMailItem As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim Atmt As Outlook.Attachment
Dim objFSO As Object
Dim sExt As String
Dim myinspector As Outlook.Inspector

Set xFileSystemObj = CreateObject("Scripting.FileSystemObject")
Set objForward = ActiveExplorer.Selection.Item(1).Forward
objForward.Display

Set xFWItems = Outlook.ActiveExplorer.Selection
Set xShellApp = CreateObject("Shell.Application")
Set xNameSpace = xShellApp.NameSpace(0)
Set myinspector = Application.ActiveInspector
Set myItem = myinspector.CurrentItem.Forward

For Each xItem In xFWItems
If xItem.Class = OlObjectClass.olMail Then
Set xMailItem = xItem
Set xAttachments = xMailItem.Attachments
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If

For Each xAttachment In xAttachments
xFilePath = xAttachment.FileName
If xFilePath Like "invoice_*.pdf" Then
xFilePath2 = xAttachment.FileName
objForward.Subject = ("[VRK] ") & xFilePath2
End If
If xFilePath Like "detailinfo_*.pdf" Then
Set objForward = Item.Forward
xAttachment.Delete
End If
Next

Next

Set Atmt = Nothing
Set xItem = Nothing
Set xNameSpaceItem = Nothing
Set xNameSpace = Nothing
Set xShellApp = Nothing
Set xFileSystemObj = Nothing

End Sub

[Grade4.2]

Try and delete the attachment from the 'objForward' object instead of the 'xItem' object.


Sub DelAttAndForward() Dim xFileSystemObj, xShellApp As Object
Dim xNameSpace, xNameSpaceItem, xItem As Object
Dim xTempFldPath, xFilePath As String
Dim xSelItems As Outlook.Selection
Dim objForward As Outlook.MailItem
Dim xAttachments As Outlook.Attachments
Dim xAttachment As Outlook.Attachment
Dim objFSO As Object
Dim sExt As String
Dim myinspector As Outlook.Inspector

Set xFileSystemObj = CreateObject("Scripting.FileSystemObject")
Set objForward = ActiveExplorer.Selection.Item(1).Forward
objForward.Display

Set xSelItems = Outlook.ActiveExplorer.Selection
Set xShellApp = CreateObject("Shell.Application")
Set xNameSpace = xShellApp.NameSpace(0)
Set myinspector = Application.ActiveInspector

For Each xItem In xSelItems
If xItem.Class = OlObjectClass.olMail Then
Set xAttachments = objForward.Attachments ' Change this line
Set objFSO = CreateObject("Scripting.FileSystemObject")

For Each xAttachment In xAttachments
xFilePath = xAttachment.FileName
If xFilePath Like "invoice_*.pdf" Then
xFilePath2 = xAttachment.FileName
objForward.Subject = ("[VRK] ") & xFilePath2
End If
If xFilePath Like "detailinfo_*.pdf" Then
xAttachment.Delete
End If
Next
End If
Next


Set Atmt = Nothing
Set xItem = Nothing
Set xNameSpaceItem = Nothing
Set xNameSpace = Nothing
Set xShellApp = Nothing
Set xFileSystemObj = Nothing
End Sub




I hope this helps your issue.

[gmayor]

The following when used as a script in conjunction with a rule will forward the message, without the unwanted attachment, on arrival. Test it with the test macro on a selected message.

Sub DelAttAndForward(olItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 15 Mar 2023
Dim olOutMail As Outlook.MailItem
Dim sAddr As String
Dim olAtt As Attachment
Dim i As Long
sAddr = "you@somewhere.com" 'the address you want the message forwarding to
If olItem.Attachments.Count >= 2 Then
For i = olItem.Attachments.Count To 1 Step -1
If LCase(olItem.Attachments(i).FileName) Like "detailinfo*" Then
Set olOutMail = olItem.Forward
With olOutMail
.To = sAddr
.CC = ""
.BCC = ""
.Display 'Change to .Send after testing
For Each olAtt In olOutMail.Attachments
If olAtt.FileName Like "detailinfo*" Then
olAtt.Delete
End If
Next olAtt
End With
Exit For
End If
Next i
End If
lbl_Exit:
Set olOutMail = Nothing
Set olAtt = Nothing
Exit Sub
End Sub

Sub TestMacro()
Dim olMsg As MailItem
'On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
DelAttAndForward olMsg
lbl_Exit:
Exit Sub
End Sub

[Erka]

Hello figure 4.2,
Thank you for your answer. I tested it and it works fine now. Thank you! My vba knowledge is not enough to see this detail, was already working on it for two days. Your Great!

[Erka]

Hi Gmayor,

Thanks for your answer, I ll try it later today.

[Aussiebear]

Erka, Welcome to the VBAX forum. If you have a solution to your query, please use the Thread Tools options and select "Mark this thread as Solved"

[Erka]

Hi Aussibear, Thanks for the tip, I was searching for the 'is solved' option.