' Original Written by Michael Bauer, vboffice.net ' //www.vboffice.net/en/developers/print-attachments-automatically ' Updated by Katy Baulch @ Ashdown Solutions Ltd to support later VBA and Office versions ' Add compatibility for different VBA versions. #If VBA7 Then 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 #Else 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 #End If Private WithEvents Items As Outlook.Items ' Set up the listener on the Inbox. Private Sub Application_Startup() Dim Ns As Outlook.NameSpace Dim Folder As Outlook.MAPIFolder Set Ns = Application.GetNamespace("MAPI") 'Set the folder and items to watch Set Folder = Ns.GetDefaultFolder(olFolderInbox) Set Items = GetFolderPath("warehouse@eastgrinstead.foodbank.org.uk\Inbox").Items Set Folder = Nothing End Sub ' Send new mail to the attachment processor. Private Sub Items_ItemAdd(ByVal Item As Object) If TypeOf Item Is Outlook.MailItem Then Debug.Print "Item is Mail" PrintAttachments Item MovePrintedMail Item Else Debug.Print TypeName(Item) End If Set Item = Nothing End Sub ' Subroutine to print all attachments with a valid file type in a given MailItem. ' ' To test this subroutine works as expected, we have created a subroutine called TestPrintAttachments. To run the test subroutine, ' click on Tools -> Macros -> Step Into. Next, open the Immediate and Locals windows (under the View ribbon). ' ' Use Function8 (F8) to go through each line. ' ' The output of any Debug.Print statements will appear in the Immediate window, and you can see the values of the variables in the ' Locals window. Sub PrintAttachments(ByRef 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 = "C:\temp\" 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", ".pdf" sFile = sDirectory & oAtt.FileName Debug.Print sFile oAtt.SaveAsFile sFile ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0 End Select Next End If End Sub Private Sub MovePrintedMail(ByRef oMail As Outlook.MailItem) Dim objDestFolder As Outlook.MAPIFolder Set objDestFolder = Session.Folders("emailaddress@com").Folders("COMPLETE") oMail.UnRead = False oMail.Save oMail.Move objDestFolder Set objDestFolder = Nothing End Sub Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder Dim oFolder As Outlook.Folder Dim FoldersArray As Variant Dim i As Integer On Error GoTo GetFolderPath_Error If Left(FolderPath, 2) = "\\" Then FolderPath = Right(FolderPath, Len(FolderPath) - 2) End If 'Convert folderpath to array FoldersArray = Split(FolderPath, "\") Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) If Not oFolder Is Nothing Then For i = 1 To UBound(FoldersArray, 1) Dim SubFolders As Outlook.Folders Set SubFolders = oFolder.Folders Set oFolder = SubFolders.Item(FoldersArray(i)) If oFolder Is Nothing Then Set GetFolderPath = Nothing End If Next End If 'Return the oFolder Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function ' Macro for a subroutine to test our PrintAttachments subroutine. Sub TestPrintAttachments() ' Create a test MailItem object. Dim testMail As MailItem Set testMail = Application.CreateItem(olMailItem) testMail.Subject = "Test subject" testMail.Body = "Test body" testMail.Attachments.Add "C:\Users\warehouse\Documents\test1.pdf", _ olByValue, 1, "test1" ' If you want to check that we have created the MailItem successfully, uncomment the 'testMail.Display' line below. ' This will open our test MailItem in a new Outlook window, so keep a look out! ' testMail.Display ' Execute our PrintAttachments subroutine on the test MailItem. Project1.ThisOutlookSession.PrintAttachments testMail End Sub