Forward selected emails without non-PDF attachments - vba

Question

I am trying to send a completed work email containing multiple PDF attachments, I wish send only the PDF files to the recipient and avoid any other atttachments such as excel files or image files only pdf to be forwarded.
P.S. note email may have more than 1 attachments with combination of pdfs, excels, images, however only pdfs have to be forwarded. I'm unable to find how to code that part. please see below my existing code.
Sub Send2Recipient()
' Send Completed Message to Recipient
On Error Resume Next
Dim oApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Set oApp = New Outlook.Application
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Folders("Helpdesk")
Dim oEmail As Outlook.MailItem
Dim strFile As String
Dim sFileType As String
'Require that this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
Response = MsgBox("Forward message (" + item.Subject + ") to Appended Subject")
Set myforward = objItem.Forward
myforward.Body = "Scan Only"
myforward.Subject = "Scan Only"
myforward.Recipients.Add "DHL.GB01PREV#dhl.com"
myforward.Display
End If
End If
Next
End Sub
Updated VBA script
Sub Send2New()
' Send Completed Message to Accenture
On Error Resume Next
Dim oApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Set oApp = New Outlook.Application
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
'Set objFolder = objInbox.Folders("Helpdesk")
Dim oEmail As Outlook.MailItem
Dim strFile As String
Dim sFileType As String
Dim bk, fg As Integer
'Require that this procedure be called only when a message is selected
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olmail Then
Response = MsgBox("Forward message (" + Item.Subject + ") to Appended Subject")
Set myforward = objItem.Forward
myforward.Body = "Scan Only"
myforward.Subject = "Scan Only"
myforward.Recipients.Add "xyz#abc.com"
myforward.Display
bk = myforward.Attachments.Count
fg = 1
For i = 1 To bk
If InStr(LCase(myforward.Attachments(fg).FileName), ".pdf") = 0 Then
myforward.Attachments(fg).Delete
Else: fg = fg + 1
End If
Next i
End If
End If
Next
End Sub

Answer 1

I have created two macros for you.
The first, Investigate, outputs information about attachments to the Immediate Window. There are four types of attachment. A “standard” attachment is of type “By Value”. I have never seen an OLE attachment and do not know what such an attachment is. I have seen the other types but not for many years.
The second, ForwardEmailsWithoutNonPdfAttachments(), demonstrates the functionality you seek. I have sent emails containing a selection of attachments from my Gmail account to my Outlook account and have used the macro to send them back with the non-PDF attachments deleted. These attachments were all “By Value” attachments. I am not sure what would happen if you tried to forward emails with other types of attachments which is the reason for the first macro. This macro is not very elegant but it demonstrates the techniques necessary to meet your objective.
Option Explicit
Public Sub Investigate()
Dim AttachType As String
Dim Exp As Outlook.Explorer
Dim InxAttach As Long
Dim ItemCrnt As MailItem
Dim NumAttach As Long
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
Debug.Print "From: " & .SenderName & " | Subject: " & .Subject
For InxAttach = 1 To .Attachments.Count
' There are four types of attachment:
' * olByValue 1
' * olByReference 4
' * olEmbeddedItem 5
' * olOLE 6
With .Attachments(InxAttach)
Select Case .Type
Case olByValue
AttachType = "Val"
Case olEmbeddeditem
AttachType = "Ebd"
Case olByReference
AttachType = "Ref"
Case olOLE
AttachType = "OLE"
Case Else
AttachType = "Unk"
End Select
Debug.Print AttachType & " " & .FileName & " | " & .DisplayName
End With ' .Attachments(InxAttach)
Next ' ItemCrnt
End With
Next
End If
End Sub
Sub ForwardEmailsWithoutNonPdfAttachments()
Dim AttachType As String
Dim Exp As Outlook.Explorer
Dim InxAttach As Long
Dim ItemCopy As MailItem
Dim ItemOrig As MailItem
Dim NumAttach As Long
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemOrig In Exp.Selection
Set ItemCopy = ItemOrig.Copy
With ItemCopy
.Subject = "FW: " & .Subject
' Delete all original recipients
Do While .Recipients.Count > 0
.Recipients.Remove (1)
Loop
' Add new recipient
.Recipients.Add "tonydallimore23#gmail.com"
If .Attachments.Count > 0 Then
For InxAttach = .Attachments.Count To 1 Step -1
With .Attachments(InxAttach)
' This will stop the macro if an attachment is not a regular attachment
Debug.Assert .Type = olByValue
If LCase(Right$(.FileName, 4)) <> ".pdf" Then
.Delete
End If
End With ' .Attachments(InxAttach)
Next InxAttach
End If
.Send
End With ' ItemCopy
Set ItemCopy = Nothing
Next ItemOrig
End If
End Sub