Consulting

Results 1 to 4 of 4

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

  1. #1
    VBAX Newbie
    Joined
    Mar 2022
    Posts
    3
    Location

    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:

    
    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
    Last edited by ibcover; 03-21-2022 at 05:46 AM.

  2. #2
    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.
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Mar 2022
    Posts
    3
    Location
    Quote Originally Posted by gmayor View Post
    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.
    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)

  4. #4
    VBAX Newbie
    Joined
    Mar 2022
    Posts
    3
    Location
    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?

    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •