Macro to Print only selected email attachments

Heyy, I currently recieve around 100+ emails a day each with one pdf attachment in them. What i would like to be able to do is select the emails with attachments in them and run a macro that will print only the attachment from each email. I do not want the email to be printed only the attachment as having to spend ages each day selecting each individual email an print each pdf one at a time is very time consuming. If i could have some macro code that would allow me to be able to do what im hopeing to accomplish it would be greatly apreciated thanks in advance if you are abler to help me :D

Put the messages to process in a sub folder of Inbox and run the macro ProcessFolder below. You can test it by selecting a single message and run the macro ProcessAttachment.

Code:

---

Option Explicit
#If Win64 Then
Public 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
Public 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

Sub ProcessAttachment()
'Graham Mayor - http://www.gmayor.com - Last updated - 02 Sep 2017 Dim olMsg As MailItem
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    PrintAttachments olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Sub ProcessFolder()
'Graham Mayor - http://www.gmayor.com - Last updated - 02 Sep 2017
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As MailItem
    On Error GoTo err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder
    Set olItems = olMailFolder.Items
    For Each olMailItem In olItems
        PrintAttachments olMailItem
        DoEvents
    End If
Next olMailItem
err_Handler:
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Sub PrintAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 02 Sep 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim j As Long
Dim strSaveFldr As String

    strSaveFldr = Environ("TEMP") & "\"

    On Error GoTo lbl_Exit
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If LCase(olAttach.fileName) Like "*.pdf" Then
                strFname = olAttach.fileName
                olAttach.SaveAsFile strSaveFldr & strFname
                NewShell strSaveFldr & strFname, 0
                DoEvents
            End If
        Next j
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Sub NewShell(cmdLine As String, lngWindowHndl As Long)
    ShellExecute lngWindowHndl, "print", cmdLine, "", "", 0
lbl_Exit:
    Exit Sub
End Sub

---

Hello and thank you for your reply, The second paragraph from your code after the #else was appearing in red but im assuming that its the same as the top one so i copied and pasted over it and its all blue and black with nothing in red. and at the end. I have named my sub Folder ProcessFolder and tried to run the process folder macro but got a compile error end if without block if under the processfolder macro,

I then select the emails that i have in that folder and run the process attachment macro and it prints the attachment however it only prints one of the email attachments?
So it definetly works on printing one email but how can i get it to print the attachments on all selected emails?

Code:

---

Option Explicit
#If Win64 Then
    Public 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
      Public 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
#End If
 
Sub ProcessAttachment()
    'Graham Mayor -  - Last updated - 02 Sep 2017 Dim olMsg As MailItem
    Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    PrintAttachments olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub
 
Sub ProcessFolder()
    'Graham Mayor -  - Last updated - 02 Sep 2017
    Dim olNS As Outlook.NameSpace
    Dim olMailFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olMailItem As MailItem
    On Error GoTo err_Handler
    Set olNS = GetNamespace("MAPI")
    Set olMailFolder = olNS.PickFolder
    Set olItems = olMailFolder.Items
    For Each olMailItem In olItems
        PrintAttachments olMailItem
        DoEvents
 
Next olMailItem
err_Handler:
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub
 
Private Sub PrintAttachments(olItem As MailItem)
    'Graham Mayor - - Last updated - 02 Sep 2017
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    Dim strSaveFldr As String
   
    strSaveFldr = Environ("TEMP") & "\"
   
    On Error GoTo lbl_Exit
    If olItem.Attachments.Count > 0 Then
        For j = 1 To olItem.Attachments.Count
            Set olAttach = olItem.Attachments(j)
            If LCase(olAttach.FileName) Like "*.pdf" Then
                strFname = olAttach.FileName
                olAttach.SaveAsFile strSaveFldr & strFname
                NewShell strSaveFldr & strFname, 0
                DoEvents
            End If
        Next j
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub
 
Private Sub NewShell(cmdLine As String, lngWindowHndl As Long)
    ShellExecute lngWindowHndl, "print", cmdLine, "", "", 0
lbl_Exit:
Exit Sub
End Sub

---

This is what the code in my module currently looks like, the process folder now works however when i have four different emails in my process folder it prints the same one four times? how do i get it to print each one once?

If the second segment after #Else is shown in red, it suggests that you have the 64 bit version of Outlook and the red is normal in such circumstances as the code in the #Else segment is not compatible with 64 bit, which is why the alternatives are presented. However if you have the 64 bit version it doesn't matter that you have changed it.

I don't understand what you mean by
'I have named my sub Folder ProcessFolder and tried to run the process folder macro but got a compile error end if without block if under the processfolder macro,'

Just ignore that i got it working (kinda)< when i select the folder from the process folder macro for example if i have two emails in there it prints the first email twice instead of printing them each once can you help me with this? For example: if i have 4 emails in there and run the macro it prints the first email 4 times =[ are you able to help me to get it to print each email once?

Attachment 20260

Remove the End If line. I had removed it from the original Reply.

Yeah i did delete it :D however when i select the folder from the process folder macro for example if i have two emails in there it prints the first email twice instead of printing them each once can you help me with this? For example: if i have 4 emails in there and run the macro it prints the first email 4 times =[ are you able to help me to get it to print each email once?

Hmmm. It should work.
Change the line
NewShell strSaveFldr & strFname, 0
to
Debug.Print strSaveFldr & strFname
does it list the files in the local window?
If it does change the line back and
change the line
ShellExecute lngWindowHndl, "print", cmdLine, "", "", 0
to
ShellExecute lngWindowHndl, "open", cmdLine, "", "", 3
are all the documents opened in your PDF application?
If so change open to print and try again.
As you have indicated you have the 64 bit version of Office I cannot test this. It works as intended here in 32 bit Outlook.

For the first part yes the list shows the files in a local window,
For the Second Part It only opens one of the attachments. =[

Hi,

Many thanks for this, it has been a great help for me when printing off large amounts of attachments. However, i recently ran into an issue with it and have been trying to figure a solution for a couple of days now and having no luck.

Sometimes we receive multiple emails (x) from the same sender with the same attachment names and a different subject (i assume they are automatically sent from their end using a program), when the macro is ran it manages to filter through the emails but prints the same attachment x times.

For example, if we receive 12 emails from from the same email where the attachments are all different but are all called invoice.pdf, it would print the same attachment 12 times.

Do you have any ideas on how to get around this, i have tried a couple of ways and seem to have no success.

Thanks again and appreciate any help that can be given.