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

[ibcover]

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:

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