Macro to Print Outlook email attachments as they arrive

Last reviewed on October 28, 2013

Today's entry in the lazy programmer series involves tweaking the code sample at Attachment: Print received attachments immediately so that it works with 4-character extensions and also with 64-bit Outlook 2010 or 2013. (The original macro works with 32-bit Outlook).

For third party add-ins and utilities, see Print Email (and Attachments) on Arrival

The code looks at the last 4 characters, including the period and will work as long as you use 4 characters in each extension we want to check.

Case "xlsx", "docx", ".pdf", ".doc", ".xls"

To use the macro with 64-bit Outlook, you need to add PtrSafe to Declare:

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _

Print received attachments immediately code sample

Original code was written for 32-bit Outlook and 3 character file extensions.

To use, open the VBA editor using Alt+F11 and paste the following code into ThisOutlookSession. Edit the code as needed then click in the Application_Startup() macro and press Run button (F8). This starts the macro without the need to restart Outlook.

' Written by Michael Bauer, vboffice.net
' http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=3&cmd=showitem

' use  Declare PtrSafe Function with 64-bit Outlook
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder

  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
  End If
End Sub

Private Sub PrintAttachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String

  sDirectory = "D:\Attachments\"

  Set colAtts = oMail.Attachments

  If colAtts.Count Then
    For Each oAtt In colAtts

' This code looks at the last 4 characters in a filename
      sFileType = LCase$(right$(oAtt.FileName, 4))

      Select Case sFileType

' Add additional file types below
      Case ".xls", ".doc", "docx"

        sFile = sDirectory  & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
      End Select
    Next
  End If
End Sub


Print attachments then move the message

If you want to print the attachment then move the message to another folder, you'll either need to add the move code to the ItemAdd macro or add another macro and call it from the ItemAdd macro.

In this example, I'm adding a new macro and calling it from the ItemAdd macro, after the PrintAttachments macro is called.

  If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
    MovePrintedMail Item
  End If

At the end of the module, after the PrintAttachments macro, add the move macro. This macro assumes the "move to folder" is a subfolder of the Inbox. Don't forget to change the mailbox name, using the name as it appears in the Folder list (it's your email address in newer versions of Outlook).

Sub MovePrintedMail(oMail As Outlook.MailItem)
  Dim objDestFolder As Outlook.MAPIFolder

   Set objDestFolder = Session.Folders("mailbox name")._
     Folders("Inbox").Folders("Printed")

     oMail.Move objDestFolder 
   
  Set objDestFolder = Nothing
End Sub

 

Use Acrobat's Printer Options

If you own Adobe Acrobat, you can set the pages you want to print and "shrink to fit" using the PrintPages function of Acrobat:
Function PrintPages(nFirstPage As Long, nLastPage As Long, nPSLevel As Long, bBinaryOk As Long, bShrinkToFit As Long) As Boolean

To use Acrobat's object model, you need to set a reference to Acrobat in the VB Editor's Tool, References dialog box.

This will not work with Reader, you need to own Acrobat. I tested it with Acrobat X but it should work with any version of Acrobat. To the best of my knowledge, both Acrobat Standard and Acrobat Pro include OLE support.

Change the Select Case code in the PrintAttachments macro to the following. If you are only printing PDF files, you can remove the Case statement that prints Excel and Word files.

To print no more than first 2 pages, use AcrobatPrint sFile


      Select Case sFileType

' Add additional file types below
      Case ".xls", ".doc", "docx"
 
        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
        
' Print PDF
     Case ".pdf"
        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        AcrobatPrint sFile, "All"


      End Select

After changing the Select case block, add the AcrobatPrint macro to your module, inserting it after the PrintAttachments macro.


Public Sub AcrobatPrint(FileName As String, PrintMode As String)

     Dim AcroExchApp As Acrobat.CAcroApp
     Dim AcroExchAVDoc As Acrobat.CAcroAVDoc
     Dim AcroExchPDDoc As Acrobat.CAcroPDDoc
     Dim num As Integer

     Set AcroExchApp = CreateObject("AcroExch.App")
     Set AcroExchAVDoc = CreateObject("AcroExch.AVDoc")

     ' Open the pdf file
     AcroExchAVDoc.Open FileName, ""

     Set AcroExchPDDoc = AcroExchAVDoc.GetPDDoc

     ' Get the number of pages for this pdf
     ' Subtract one because the count is 0 based
     num = AcroExchPDDoc.GetNumPages - 1

     If PrintMode = "All" Then

     ' Print Entire Document 
     ' Last value is shrinktofit
           Call AcroExchAVDoc.PrintPages(0, num, 2, 1, 1)
     Else
           If num = 0 Then
               ' If one page, print document
                Call AcroExchAVDoc.PrintPages(0, num, 2, 1, 1)
           Else
               'Print first two pages
                Call AcroExchAVDoc.PrintPages(0, 1, 2, 1, 1)
           End If
     End If
  
     AcroExchApp.Exit
     AcroExchAVDoc.Close (True)
     AcroExchPDDoc.Close

End Sub

How to use macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To use the macro code in ThisOutlookSession:

  1. Expand Project1 and double click on ThisOutlookSession.
  2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
  3. Make sure folder in the sDirectory path exists; if not, change it to a folder that exists.
  4. Click in the Application_Startup macro and press Run (or F8) to kick start it without restarting Outlook.
  5. Send yourself a message with a Word document attachment. Outlook should print it on arrival.

More information as well as screenshots are at How to use the VBA Editor

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

57 responses to “Macro to Print Outlook email attachments as they arrive”

  1. Matt

    I am curious to how you could convert this macro to include the automatic printing of image attachments as well. Otherwise this just opens an image attachment in Picture and Fax Viewer.

  2. Anthony

    I have a qusetion about printing .tif.

    When attachment file is .tif or .tiff,it can't print silently and will show a printing wizrd,how can I avoid it?I wanna print it automatically,thanks for reply.

  3. Anthony

    After changing the default photo application to paint,it works now!Tks for help :)

  4. Debbie

    This looks great. I only want to print attachments from a specific folder. Or I would be happy with a macro that I select the message and then hit the macro to print it's attachment. Has anyone modified this macro for either of these 2 options?

  5. Bill Hall

    Hi Diane P. I added this code per instructions above and nothing is happening is a UNC path a calid path for the save?

  6. Ignacio Garcia

    The code works very well for outlook. do you have something that can work for google mail?

  7. Nancy

    Is there a way to use this to only print the 2nd page of an attachment? We are switching to Fax2Mail and every document will have a cover sheet included that we don't want to print.

  8. Michael Senra

    How would I go about printing multiple copies, like I wanted to print 2 copies of the attachment?

  9. Michael Senra

    Thanks! Works beautifully. Now, the only other question I have is whether I can make it also just print a copy of the actual email itself afterwords; sort of like a 'cover'. The premise is that my client gets a lot of overnight orders, and it's becoming a hassle to spend the first hour in the morning just printing these emails out.

    I know I can just make a rule that will print it out, but there's no way of making sure that the script runs first, or last, AFAIK depending on there needs. If I could just get it built into the script, it would make things a whole lot simpler!

    Do you know if this is possible?

  10. Leo

    Seems like 2010 I get an 'Object could not be found' error when trying to drill down to multiple folders. the script works fine on 2003 =(

  11. ruyrazn

    Hello All,

    I have the code copied into mysessionoutlook, but I am lost on what to do after that.

    Could someone highlight any changes that I need to make to reflect my system folders I'm not sure what to do.

  12. kelvin

    i tried this code and it's giving me an:
    compile error:
    only valid in object module
    message... any advice?

  13. Jason

    I'm curious if it's possible to add a parameter that the macro will not run unless it's from a certain sender address. How would one go about doing this?

  14. Jason

    That worked, but FYI, senderemailaddress does not return a traditional e-mail address if the address is from a MS Exchange server, it prints out the entire path from Active Directory.

  15. Arjen

    Hi there, tnx for the macro, working like a charm. I'm just wondering, is there any way to move the email to an different folder, say "allready printed", after the mail has been printed out?

    Tnx!

  16. Atul

    Diane,

    This is nothing short of a miracle. I am not finding the right words to to thank you for this master piece.

    I have made a little change to this and established a process to move the emails that I want to print attachments from, to a new folder under Inbox. I works perfect. However there is a situation in which it does not work correctly. I receive multiple emails from the same email address on same date and at same time. The attachments in each email are different scan images however they all have same name "document.pdf". When I move a batch of emails containing attachment with same name, only one document gets printed multiple times. I tried to sort them on date, time etc but still got the same result. The work around I found is to transfer one email at a time to the folder for printing.

    I there any tweek in the code that you could suggest, which would resolve this problem?

    Thanks for your help!

  17. Atul

    Thank you Diane,
    This worked perfect. Thanks for your prompt help.

  18. Mike

    here is the code I used and it prints great, but don't move the email to the folder as I need it to!

    Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set Ns = Application.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)
    Set Items = Folder.Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
    MovePrintedMail Item
    End If
    End Sub

    Private Sub PrintAttachments(oMail As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "T:\Attachments\"

    Set colAtts = oMail.Attachments

    If colAtts.Count Then
    For Each oAtt In colAtts

    sFileType = LCase$(Right$(oAtt.FileName, 4))

    Select Case sFileType
    Case ".pdf"
    sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
    oAtt.SaveAsFile sFile
    ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
    End Select
    Next
    End If
    End Sub
    Sub MovePrintedMail(oMail As Outlook.MailItem)
    Dim objDestFolder As Outlook.MAPIFolder
    Set objDestFolder = Session.Folders("JSOTOL ASAP"). _
    Folders("Inbox").Folders("Printed")
    oMail.Move objDestFolder
    Set objDestFolder = Nothing
    End Sub

    any idea where the code is wrong? I have tried with the email address and the inbox name and nothing...

  19. Chris

    Hi Diane,

    The code works great - thank you!!

    One question: Is there a way to clean up the "Attachment" directory after each print job?

    Thanks again!

    Regards

  20. Andy

    I'm also having a problem with moving the email after printing, I get the error "Folders - Sub or function not defined"

  21. Joeri van Woudenberg

    Dear Diane, i still cant get it to work with the basic code.. i need to print all incoming attachments(faxes as PDF) to our default printer. I cant figure out why its all failing and its not printing at all.. I just over copyed the code above for attachments and adjusted the save location. Can you help me out?

  22. Jos

    Hello,

    To print pdf's, I need Acrobat pro (as mentioned above ), because acrobat reader doesn't support OLE.

    Nevertheless I can use acrobat reader with the following code =>

    strPath = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe"
    If Len(Dir(strPath)) > 0 Then
    strPath = strPath & " /N /T " & Chr(34) & FullFile & Chr(34)
    Retval = Shell(strPath, vbMinimizedNoFocus)
    End If

    It works fine for me and I don't need Acrobat pro for this.to print pdf's

  23. Henry

    Hello Diane,

    The print work perfectly but the printed mail don't move to the specific folder i pointed to.

    Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set Ns = Application.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)
    Set Items = Folder.Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
    End If
    End Sub

    Private Sub PrintAttachments(oMail As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "D:\Attachments\"

    Set colAtts = oMail.Attachments

    If colAtts.Count Then
    For Each oAtt In colAtts

    ' This code looks at the last 4 characters in a filename
    sFileType = LCase$(right$(oAtt.FileName, 4))

    Select Case sFileType

    ' Add additional file types below
    Case ".xls", ".doc", "docx"

    sFile = sDirectory & oAtt.FileName
    oAtt.SaveAsFile sFile
    ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
    End Select
    Next
    End If
    End Sub
    Sub MovePrintedMail(oMail As Outlook.MailItem)
    Dim objDestFolder As Outlook.MAPIFolder

    Set objDestFolder = Session.Folders("Printed")._
    Folders("Inbox").Folders("Printed")

    oMail.Move objDestFolder

    Set objDestFolder = Nothing
    End Sub

    I am using Outlook 2007. I've tried Joris Robijn or jrobijn or the folder name Printed(just under the inbox).I also tried this.
    Set objDestFolder = GetFolderPath("JSOTOL ASAP\Inbox\Printed")

    Still don't move the message, sometimes i get this error code 2147221233 (8004010f).
    Please help me.

    Thanks in advance.

  24. Oscar

    Hi Diane

    I have Outlook 2010 64 bit and can't get this Macro visible in my Macro list.
    Do you have any ideas what could be the problem?

    1. I hit ALT +F11 and copied the 64bit code inside ThisOutlookSession:
    ' Written by Michael Bauer, vboffice.net
    ' http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=3&cmd=showitem

    ' use Declare PtrSafe Function with 64-bit Outlook
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set Ns = Application.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)
    Set Items = Folder.Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
    End If
    End Sub

    Private Sub PrintAttachments(oMail As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "D:\Attachments\"

    Set colAtts = oMail.Attachments

    If colAtts.Count Then
    For Each oAtt In colAtts

    ' This code looks at the last 4 characters in a filename
    sFileType = LCase$(Right$(oAtt.FileName, 4))

    Select Case sFileType

    ' Add additional file types below
    Case ".pdf", ".doc", "docx"

    sFile = sDirectory & oAtt.FileName
    oAtt.SaveAsFile sFile
    ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
    End Select
    Next
    End If
    End Sub

    2. I signed the macro, but nothing changed

    3. when I change Private Sub Application_Startup() to Sub Application_Startup() the macro is visible in the macro list

  25. Adam

    Hello Diane,
    Thank you for the excellent script. It works like a charm!

    Is there any way to choose a different network printer than the default? Thank you in advance.

  26. Torch

    Hello Diane,
    That's Great!
    The macro works perfectly.

    Is there any way to choose the paper quality? like A4 or A3 and choose duplex options when print?

    Thank you!

  27. Muktar

    Hi Diane,
    nice micro, works perfect, Thank you

    need little help on....
    I get 2 pdf attachment in each email, one of the pdf i need 3 copes and the other one only one copy,

    for example ( order_123_1234.pdf & 1234567890.pdf )

    Thank you.

  28. tara

    Hi Diane,

    cannot figure out what I am doing wrong, I have office 2007 so tried 32 and 64bit.
    have enabled macros but still not working.

    Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

    Private WithEvents Items As Outlook.Items

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set Ns = Application.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox).Folders("Invoices")
    Set Items = Folder.Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
    PrintAttachments Item
    End If
    End Sub

    Private Sub PrintAttachments(oMail As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "H:\Attachments\"

    Set colAtts = oMail.Attachments

    If colAtts.Count Then
    For Each oAtt In colAtts

    sFileType = LCase$(Right$(oAtt.FileName, 4))

    Select Case sFileType
    Case ".xls", ".doc"
    sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
    oAtt.SaveAsFile sFile
    ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
    End Select
    Next
    End If
    End Sub

  29. tara

    yes a message box came up when i did that.
    Have had no error messages.

Leave a Reply

If the Post Coment button disappears, press your Tab key.