Delete specific att and forward message

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:

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

---

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

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 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.

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.

Code:

---

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

---

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!

Hi Gmayor,

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

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"

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