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