Print all attachments from new mails that are moved into specific folder

Hi all.

Hoping someone can help me out here. I have a rule set up so specific mails get auto sent to a folder named Print. What I am trying to do now is to set a vba script that will monitor the folder "Print" and in turn print all emails that are sent to this folder. Preferably, I'd like the script to print out only the attachments or any jpg, png, tif or gif files that are in the email to avoid wasting paper.

So far I have found this script which errors on me when I try and load it. Subsequently, when I receive anything that matches my rule, it gets sent to the Print folder but nothing happens:

Code:

---

''From here starts the function to print anything added to the specified folder.
Public WithEvents objSpecificFolder As Outlook.Folder
Public WithEvents objItems As Outlook.Items


Private Sub Application_Startup()
    'Specify the folder
    'You can change it as per your needs
    Set objSpecificFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Print")
    Set objItems = objSpecificFolder.Items
End Sub


'Macro works when new item lands into the specific folder
Private Sub objItems_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem


    If TypeOf Item Is MailItem Then
      Set objMail = Item
      'Print this mail
      objMail.PrintOut
    End If
End Sub

'Above this line ends the printing of files added to specified folder

---

Could anyone help me out?

In order to print the attachments, you will need an application capable of printing the images, which Outlook cannot do. Windows Paint is a possibility and you should have that so ...
The macro which can be run from a rule saves the images into the User's Temp folder then prints the images that are attachments. The macro includes a line to exclude images that are in the message body (which could include the signature logos). If you are sure that you want to print those images also then remove the line

Code:

---

If Not olAttach.fileName Like "image*.*" Then

---

and its associated End If.

Frankly I don't see this saving much paper as all the images will be printed to separate sheets.

Code:

---

Sub TestPrint()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    PrintAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub


Private Sub PrintAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 08 Mar 2018
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 Not olAttach.fileName Like "image*.*" Then
                strFname = olAttach.fileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                Select Case LCase(strExt)
                    Case Is = "tif", "jpg", "png", "gif"
                        olAttach.SaveAsFile strSaveFldr & strFname
                        Shell "cmd /c mspaint /p " & strSaveFldr & strFname
                    Case Else
                End Select
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

---

Quote:

---

Originally Posted by gmayor

In order to print the attachments, you will need an application capable of printing the images, which Outlook cannot do. Windows Paint is a possibility and you should have that so ...
The macro which can be run from a rule saves the images into the User's Temp folder then prints the images that are attachments. The macro includes a line to exclude images that are in the message body (which could include the signature logos). If you are sure that you want to print those images also then remove the line

---

Thanks for taking the time to reply.

I forgot to mention that due to Group Policy implemented by IT, our notebooks have seen the "run script" option removed from Outlook, as can be seen here.

https://i.imgur.com/TZh0DCJ.png

Using the "print it" option prints out everything, including some hefty email bodies that are useless to me.

I said it CAN be run from a rule, not that it MUST be. The test macro runs the main macro on a selected message. You could loop through a folder and run the code on all the messages in that folder (or all that meet certain criteria) or you can call it from your item add function.

Quote:

---

Originally Posted by gmayor

I said it CAN be run from a rule, not that it MUST be. The test macro runs the main macro on a selected message. You could loop through a folder and run the code on all the messages in that folder (or all that meet certain criteria) or you can call it from your item add function.

---

I confess that what you are saying sounds lovely... Unfortunately I do not speak fluent VBA. :crying:

Let me try and wrap my head around it. So I'd have to somehow change the code so that it looks only at files coming into my Print folder and the triggers the print?

Replace the code in the ThisOutlookSession module with

Code:

---

Option Explicit

Private WithEvents objItems As Outlook.Items

Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objWatchFolder As Outlook.Folder

    Set objNS = Application.GetNamespace("MAPI")
    Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).folders("Print")

    Set objItems = objWatchFolder.Items
lbl_Exit:
    Exit Sub
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        PrintAttachments Item
    End If
lbl_Exit:
    Exit Sub
End Sub

---

Put the code from my previous message in an ordinary VBA module that you will have to insert i.e.

Code:

---

Option Explicit


Public Sub PrintAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 08 Mar 2018
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 Not olAttach.fileName Like "image*.*" Then
                strFname = olAttach.fileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                Select Case LCase(strExt)
                    Case Is = "tif", "jpg", "png", "gif"
                        olAttach.SaveAsFile strSaveFldr & strFname
                        Shell "cmd /c mspaint /p " & strSaveFldr & strFname
                    Case Else
                End Select
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

---

Run the macro Application_Startup manually or restart Outlook (don't forget to save the project) and move a message with an image attachment into they Print subfolder of the default Inbox.

Quote:

---

Originally Posted by gmayor

Run the macro Application_Startup manually or restart Outlook (don't forget to save the project) and move a message with an image attachment into they Print subfolder of the default Inbox.

---

Getting the following error when running or starting
Attachment 21772

It looks like you have scrolled the module to enable that to be seen, which suggests you have more code above it. The code I posted should be at the top of the ThisOutlookSession module and should not duplicate any code already in that module,

Quote:

---

Originally Posted by gmayor

It looks like you have scrolled the module to enable that to be seen, which suggests you have more code above it. The code I posted should be at the top of the ThisOutlookSession module and should not duplicate any code already in that module,

---

You are correct. Moving the script to the top did solve the error but I got another one. I searched around and this one seems to pertain to the folder path. I have tried creating a folder at the root of my mailbox named Print and another inside my "Folders" folder also named Print.

I gather I have the folder in the wrong place. Trying to solve it.
Attachment 21778Attachment 21779Attachment 21780Attachment 21781

Do yuou have a folder called Inbox? Print should be a sub folder of Inbox

Code:

---

objNS.GetDefaultFolder(olFolderInbox).folders("Print")

---

Quote:

---

Originally Posted by gmayor

Do yuou have a folder called Inbox? Print should be a sub folder of Inbox

Code:

---

objNS.GetDefaultFolder(olFolderInbox).folders("Print")

---

---

My inbox is in Portuguese although my Office and Outlook is setup for english. Hence it reads "A Receber". I think it's a locale issue. However, creating a Print folder under that solved the error.

And the result, dear sir, is nothing short of God damn forking brilliant! Who da man?! YOU da man!!!

That's great stuff. Thanks so much.

I have been tinkering with the code. I added a different image viewer as the print application. And I am trying to get other formats to print like pdf. Image prints perfectly. PDF won't print at all. Running over the script I don't think you limited printing to just image files. Any idea why PDF won't print?

Code:

---

'This is the module for the auto print function. It relies also on a part in the ThisOutlookSession.Option Explicit




Public Sub PrintAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 08 Mar 2018
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 Not olAttach.FileName Like "image*.*" Then
                strFname = olAttach.FileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                Select Case LCase(strExt)
                    'Case Is = "tif", "jpg", "png", "gif"
                    '    olAttach.SaveAsFile strSaveFldr & strFname
                    '    'Shell "cmd /c mspaint /p " & strSaveFldr & strFname
                    '    Shell "cmd /c D:\work\PortableApps\PortableApps\IrfanViewPortable\App\IrfanView\i_view32.exe " & strSaveFldr & strFname & " /print"
                    'Case Else
                    'Changes start
                    Case Is = "tif", "jpg", "png", "gif"
                        olAttach.SaveAsFile strSaveFldr & strFname
                        Shell "D:\work\PortableApps\PortableApps\IrfanViewPortable\App\IrfanView\i_view32.exe " & strSaveFldr & strFname & " /print"
                    Case Is = "pdf"
                        olAttach.SaveAsFile strSaveFldr & strFname
                        Shell "D:\work\PDFtoPrinter\PDFtoPrinter.exe" & strSaveFldr & strFname
                    Case Else
                    'Changes end
                End Select
            End If
        Next j
        olItem.Save
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

---

Edit: Nevermind. Being the idiot that I am, I forgot to leave a space after the executable.

Code:

---

Shell "D:\work\PDFtoPrinter\PDFtoPrinter.exe " & strSaveFldr & strFname

---

That fixed it. Great stuff.