Macro to Print Outlook email attachments as they arrive

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