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

[nmgmarques]

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:

''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?

[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

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.


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

[nmgmarques]

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.

[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.

[nmgmarques]

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?

[gmayor]

Replace the code in the ThisOutlookSession module with


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.


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.

[nmgmarques]

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
21772

[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,

[nmgmarques]

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.
21778217792178021781

[gmayor]

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

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

[nmgmarques]

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

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.

[nmgmarques]

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?


'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.

Shell "D:\work\PDFtoPrinter\PDFtoPrinter.exe " & strSaveFldr & strFname
That fixed it. Great stuff.