Option Explicit ' 'Code from http://www.slipstick.com/developer/print-attachments-as-they-arrive/ - amended by XYZ - 15-July-2014 ' 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 --- Sub SendtoPrint() Dim obj Dim oCategory As Outlook.Category Dim items Dim recentItem As Outlook.MailItem Dim strNewEmailSubject As String Dim intUserAnswer As Integer Set obj = ActiveInspector.CurrentItem If Len(obj.To) > 0 And Len(obj.Subject) > 0 Then strNewEmailSubject = obj.Subject obj.Send 'XYZ 15 July 2014 - code taken from: 'http://social.msdn.microsoft.com/Forums/office/en-US/13805d87-ed1a-4575-af37-46e66fc67b4a/outlook-item-index-for-most-recent-email-use-folder-count?forum=outlookdev Set items = Session.GetDefaultFolder(olFolderSentMail).items items.Sort "CreationTime", True Set recentItem = items.Item(1) recentItem.PrintOut If recentItem.Attachments.Count > 0 Then Select Case recentItem.Attachments.Count Case 1 intUserAnswer = MsgBox("There is " & CStr(recentItem.Attachments.Count) & " attachment to this email. Do you wish to print it ?", vbYesNo) Case Else 'More than one attachment intUserAnswer = MsgBox("There are " & CStr(recentItem.Attachments.Count) & " attachments to this email. Do you wish to print these ?", vbYesNo) End Select If intUserAnswer = vbYes Then PrintAttachments items.Item(1) Else MsgBox "The attachments will not be printed" End If Else MsgBox "There are no attachments." End If Else MsgBox "Please ensure that this email has BOTH a Recipient AND a Subject and then retry.", vbCritical, "XYZ Ltd error message" End If End Sub ------- Private Sub PrintAttachments(oMail As Outlook.MailItem) 'Code from http://www.slipstick.com/developer/print-attachments-as-they-arrive/ - amended by XYZ - 15-July-2014 On Error Resume Next Dim colAtts As Outlook.Attachments Dim oAtt As Outlook.Attachment Dim strFile As String Dim strDirectory As String Dim strFileType As String strDirectory = "C:\_EmailAttachments\" Set colAtts = oMail.Attachments If colAtts.Count Then For Each oAtt In colAtts strFileType = LCase$(Right$(oAtt.FileName, 4)) Select Case strFileType Case ".xls", ".doc", "xlsx", ".pdf", "docx" strFile = strDirectory & oAtt.FileName oAtt.SaveAsFile strFile 'This line carries out the print, providing the attachment is a Word, Excel or PDf file - based on the file extension ShellExecute 0, "print", strFile, vbNullString, vbNullString, 0 'Call WaitTimer 'Delete file from folder Case Else 'Do nothing End Select Next Call WaitTimer("00:00:05") Kill strDirectory & "*.*" End If End Sub Private Sub WaitTimer(strChosenDelayTimeInSeconds As String) 'Private Sub WaitTimer() Dim currenttime As Date 'wait for printing currenttime = Now 'Do Until currenttime + TimeValue("00:00:07") <= Now Do Until currenttime + TimeValue(strChosenDelayTimeInSeconds) <= Now Loop