Outlook VBA: Remove specific attachments and print remaining email and attachtments

I have adopted online code to delete unwanted graphics in message body and attachments and then printing the mail message-body and the remaining attachments. The macro prints the attachment two times i.e. if only one PDF document is left in the mail it is printed twice. Also the order of printing is wrong; it prints the attachments and then the mail message-body. I need it to print the message-body first and then the attachments and only one of each? Is there anybody who can help me out?

Here is the code:

Code:

---


Sub PrintAllAttachmentsInMultipleMails()

Dim xFileSystemObj, xShellApp As Object
Dim xNameSpace, xNameSpaceItem, xItem As Object
Dim xTempFldPath, xFilePath As String
Dim xSelItems 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

    Set xFileSystemObj = CreateObject("Scripting.FileSystemObject")
 
    xTempFldPath = xFileSystemObj.GetSpecialFolder(2).Path & "\Attachments " & Format(Now, "yyyymmddhhmmss") 'xFileSystemObj.GetSpecialFolder(2) For saving temporary files
 
    If xFileSystemObj.FolderExists(xTempFldPath) = False Then 'create temporary folder
        xFileSystemObj.CreateFolder (xTempFldPath)
    End If
 
    Set xSelItems = Outlook.ActiveExplorer.Selection
    Set xShellApp = CreateObject("Shell.Application")
    Set xNameSpace = xShellApp.NameSpace(0)
 
    For Each xItem In xSelItems
        If xItem.Class = OlObjectClass.olMail Then
            Set xMailItem = xItem
            Set xAttachments = xMailItem.Attachments
            Set objFSO = CreateObject("Scripting.FileSystemObject")
             
                For Each xAttachment In xAttachments
                    sExt = objFSO.GetExtensionName(xAttachment.FileName)
                    xFilePath = xTempFldPath & "" & xAttachment.FileName
 
                    Select Case sExt
                        Case "jpg", "png", "jpeg", "gif", "bmp"
                            xAttachment.Delete
                            xMailItem.BodyFormat = olFormatPlain
                            xMailItem.Save
                        Case Else
                            xAttachment.SaveAsFile (xFilePath)
                            Set xNameSpaceItem = xNameSpace.ParseName(xFilePath)
                            xNameSpaceItem.InvokeVerbEx ("print")
                    End Select
                Next
                xMailItem.PrintOut
        End If
    Next
 
    Set Atmt = Nothing
    Set xItem = Nothing
    Set xNameSpaceItem = Nothing
    Set xNameSpace = Nothing
    Set xShellApp = Nothing
    Set xFileSystemObj = Nothing

End Sub

---

I have to admit this caused a few headaches, until I realised that if you print the item it also prints the attachments (at least in Outlook 2019) so the following works for me.

Code:

---

Sub PrintAllAttachmentsInMultipleMails()

Dim oItem As Object
Dim oSelItems As Outlook.Selection
Dim olAtt As Outlook.Attachment
Dim sExt As String

    Set oSelItems = Outlook.ActiveExplorer.Selection
    For Each oItem In oSelItems
        If oItem.Class = OlObjectClass.olMail Then
            oItem.Save
            For Each olAtt In oItem.Attachments
                Select Case sExt
                    Case "jpg", "png", "jpeg", "gif", "bmp"
                        olAtt.Delete
                    Case Else
                End Select
            Next
            oItem.PrintOut
        End If
    Next

    Set olAtt = Nothing
    Set oItem = Nothing
    Set oSelItems = Nothing
End Sub

---

Quote:

---

Originally Posted by gmayor

I have to admit this caused a few headaches, until I realised that if you print the item it also prints the attachments (at least in Outlook 2019) so the following works for me.

Code:

---

Sub PrintAllAttachmentsInMultipleMails()

Dim oItem As Object
Dim oSelItems As Outlook.Selection
Dim olAtt As Outlook.Attachment
Dim sExt As String

    Set oSelItems = Outlook.ActiveExplorer.Selection
    For Each oItem In oSelItems
        If oItem.Class = OlObjectClass.olMail Then
            oItem.Save
            For Each olAtt In oItem.Attachments
                Select Case sExt
                    Case "jpg", "png", "jpeg", "gif", "bmp"
                        olAtt.Delete
                    Case Else
                End Select
            Next
            oItem.PrintOut
        End If
    Next

    Set olAtt = Nothing
    Set oItem = Nothing
    Set oSelItems = Nothing
End Sub

---

---

Thx for looking into this Graham - unfortunately it does not work in Outlook Vers. 2008 (build 13127.21506). I tried testing it with 2 mails each containing an attached pdf document and 1 attached .png fil - also each mail have 4 different graphics in the email body (.png + .bmp + .jpg + .gif) Here's what i found:

- it does not delete the graphics in the e-mail body (so they are printed ...)
-it does not delete the graphics attached (but they are not printed...)
- it prompts you 'only to print files from sources you trust' (if you print 200+ emails pr. day using this macro this gets to be too much work...)
- it only prints the first copy of the wanted attachments before giving you an error from the destination application (can't find the document to print)

Okay - After studying a bit I altered the code - problem is that I still can't print as expected. It does not print email#1 body and then email"1 attachment(s) and it stops in Acrobat Reader with a error message that the file cannot be found - anyone?

Code:

---

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' 32 bit Installation


Sub DeleteSpcificTypeOfAttachmentsAndPrint()


'Macro to loop through a selection of emails. The macro removes unwanted image files in the email body as well as attached image files
'The macro then prints the email and the attachments.




Dim xSelection As Outlook.Selection
Dim xItem As Object
Dim xMailItem As Outlook.MailItem
Dim xAttachment As Outlook.Attachment
Dim xFiletype As String
Dim xType As String
Dim xFSO As Scripting.FileSystemObject
Dim i As Integer


Set xSelection = Outlook.Application.ActiveExplorer.Selection
Set xFSO = New Scripting.FileSystemObject


For Each xItem In xSelection        'loop through the selected items
    If xItem.Class = olMail Then
      Set xMailItem = xItem
      If xMailItem.Attachments.Count > 0 Then  'check number of attachments to mail
            For i = xMailItem.Attachments.Count To 1 Step -1    'loop through number of attachments
                Set xAttachment = xMailItem.Attachments.Item(i) 'variable xAttachment = each attachment name
                xFiletype = xFSO.GetExtensionName(xAttachment.FileName) 'get extension of each attachment
                Select Case xFiletype  'If file extension is equal to listings then delete attachment
                    Case "jpg", "jpeg", "png", "gif", "tif", "emf", "wmf", "bmp", "cur", "wpg", "xml"
                        xAttachment.Delete
                    Case Else
                End Select
            Next i  'End inner loop removing graphics
        End If
      xMailItem.BodyFormat = olFormatPlain    'Set email body to plain text
      xMailItem.Save                          'Save the edited mail item
      xMailItem.PrintOut                      'Print the mail body AND attachment
      Sleep (1000)                            'Wait 1 second before proceeding to next email in the inner loop
    End If
Next    'Next mail in the selection of emails


Set xMailItem = Nothing
Set xFSO = Nothing


End Sub

---