Print .pdf attachment on reception email

[itmonitor]

Hello,

I need to setup a VBA to print the .pdf attachments from the emails received in Outlook 2016, for a certain email account. This is what I have done:

1. I setup the VBA code below) in Outlook>Developer Tab>Visual Basic>...ThisOutloookSession
2. In Tools>References I checked the box for Microsoft Scripting Runtime
3. On regedit, I enabled the key "EnableUnsafeClientMailRules"=dword:00000001

Now, I go to Outlook and setup a rule for emails received, with attachment, run a script. Clicking on `script` it will open the small window so I can select the script. But there is no script in there for me to select.

Any advice is welcome! :-)

VBA Code

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


Private WithEvents Items As Outlook.Items


Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder


Set Ns = Application.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
Set Items = Folder.Items
End Sub


Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
PrintAttachments Item
End If
End Sub


Private Sub PrintAttachments(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:\Users\J\Documents\Printed_Invoices"


Set colAtts = oMail.Attachments


If colAtts.Count Then
For Each oAtt In colAtts


sFileType = LCase$(Right$(oAtt.FileName, 4))


Select Case sFileType
Case ".pdf"
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End Sub

[gmayor]

For the script to be available for selection you will need to change

Private Sub PrintAttachments(oMail As Outlook.MailItem)
to

Public Sub PrintAttachments(oMail As Outlook.MailItem)
I have not tested your code.

[itmonitor]

Thank you. I changed according to your instruction.

I fixed also the 64bit compatibility, by changing


Private Declare Function ShellExecute Lib

into


Private Declare PtrSafe Function ShellExecute Lib

but now the routine stops with a Compile Error: Variable not Defined at


Private Sub LoadLvwColumnHeaders() Call lvwDuplicates.ColumnHeaders.Add(, , GetStringFromResource(ResId.lvwDuplicates_ColumnHeaders_Subject_Std), 200, lvwColumnLeft)

Any ideas how to fix this?

[gmayor]

That looks like it should be two lines, but this relates to code that you haven't posted


Private Sub LoadLvwColumnHeaders()
Call lvwDuplicates.ColumnHeaders.Add(, , GetStringFromResource(ResId.lvwDuplicates_ColumnHeaders_Subject_Std), 200, lvwColumnLeft)

[itmonitor]

Oh, that is true. Sorry, here you have the code:


Private Sub LoadGUI() lblFolderSelect.Caption = GetStringFromResource(ResId.lblFolderSelect_Caption_Std)
cmdEmptyCache.Caption = GetStringFromResource(ResId.cmdEmptyCache_Caption_Std)
cmdFindDuplicates.Caption = GetStringFromResource(ResId.cmdFindDuplicates_Caption_Std)
cmdShowElement.Caption = GetStringFromResource(ResId.cmdShowElement_Caption_Std)
cmdShowElement.ControlTipText = GetStringFromResource(ResId.cmdShowElement_ControlTipText_Std)
cmdDeleteDuplicate.Caption = GetStringFromResource(ResId.cmdDeleteDuplicate_Caption_Std)
cmdDeleteDuplicate.ControlTipText = GetStringFromResource(ResId.cmdDeleteDuplicate_ControlTipText_Std)
cmdDeleteChecked.Caption = GetStringFromResource(ResId.cmdDeleteChecked_Caption_Std)
cmdDeleteChecked.ControlTipText = GetStringFromResource(ResId.cmdDeleteChecked_ControlTipText_Std)
cmdClose.Caption = GetStringFromResource(ResId.cmdClose_Caption_Std)

lblCopyright.Caption = GetStringFromResource(ResId.lblCopyright_Caption_Std)

LoadLvwColumnHeaders
End Sub


Private Sub LoadLvwColumnHeaders()
Call lvwDuplicates.ColumnHeaders.Add(, , GetStringFromResource(ResId.lvwDuplicates_ColumnHeaders_Subject_Std), 200, lvwColumnLeft)
Call lvwDuplicates.ColumnHeaders.Add(, , GetStringFromResource(ResId.lvwDuplicates_ColumnHeaders_Folder_Std), 150, lvwColumnLeft)

Dim i As Integer
For i = 1 To OL_LOOKFORDUPS_MAXNUMBEROFPROPERTIES - 1
Call lvwDuplicates.ColumnHeaders.Add(, , GetStringFromResource(ResId.lvwDuplicates_ColumnHeaders_Property_Std) & " " & i, 150, lvwColumnLeft)
Next i

End Sub


Private Function GetBodyEssentials(strBody As String) As String
Dim strBodyModified As String
Dim i As Long

If Len(strBody) > 10000 Then
For i = 1 To Len(strBody) Step Len(strBody) / 100
strBodyModified = strBodyModified & Mid(strBody, i, 100)
Next i
Else
strBodyModified = strBody '' do not modify it, pass it on
End If

GetBodyEssentials = strBodyModified
End Function




''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''
'''''''''' Resource handling
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''


Private Function GetStringFromResource(ByVal intResourceIndex As ResId, ParamArray arrParams() As Variant) As String
Dim strRet As String
strRet = "N/A"


Dim lngLanguageID
lngLanguageID = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
'' lngLanguageID = msoLanguageIDEnglishUS '' temporarily switch to desired language for debugging


Select Case (lngLanguageID And &HFF) '' low 8bits characterize the language category
'' Select Case (msoLanguageIDEnglishUS And &HFF)
'' Select Case (msoLanguageIDSwissGerman And &HFF)
Case (msoLanguageIDEnglishUS And &HFF)
strRet = Language_English(intResourceIndex, arrParams)
Case (msoLanguageIDGerman And &HFF)
strRet = Language_German(intResourceIndex, arrParams)
Case Else
strRet = Language_English(intResourceIndex, arrParams)
End Select



If strRet = Empty Then
'' fallback language
strRet = Language_English(intResourceIndex, arrParams)
End If


GetStringFromResource = strRet
End Function


Private Function Language_English(intResourceIndex As ResId, ByVal arrParams As Variant) As String
Dim strRet As String
strRet = Empty


Select Case intResourceIndex
'' gui strings
Case ResId.lblFolderSelect_Caption_Std
strRet = "Select the folders, in which to look for duplicates:" & vbNewLine & vbNewLine & "(Folders in cache, which were already scanned, are automatically included. Empty the folder cache to deselect these folders.)"
Case ResId.cmdEmptyCache_Caption_Std
strRet = "Empty folder cache"
Case ResId.cmdFindDuplicates_Caption_Std
strRet = "Find duplicates"
Case ResId.cmdFindDuplicates_Caption_Cancel
strRet = "Cancel"
Case ResId.cmdShowElement_Caption_Std
strRet = "Show selected"
Case ResId.cmdShowElement_ControlTipText_Std
strRet = "Opens a detailed view of the selected item"
Case ResId.cmdDeleteDuplicate_Caption_Std
strRet = "Delete selected"
Case ResId.cmdDeleteDuplicate_ControlTipText_Std
strRet = "Moves the selected duplicate to the folder ""Deleted Items"""
Case ResId.cmdDeleteChecked_Caption_Std
strRet = "Delete all checked"
Case ResId.cmdDeleteChecked_ControlTipText_Std
strRet = "Moves all of the checked items to the folder ""Deleted Items"""
Case ResId.cmdClose_Caption_Std
strRet = "Close"
Case ResId.lblCopyright_Caption_Std
strRet = " Outlook LookForDuplicates v" & OL_LOOKFORDUPS_VERSION & " " & OL_LOOKFORDUPS_RELEASEDATE & " © by Meigel"
Case ResId.lvwDuplicates_ColumnHeaders_Subject_Std
strRet = "Subject"
Case ResId.lvwDuplicates_ColumnHeaders_Folder_Std
strRet = "Folder"
Case ResId.lvwDuplicates_ColumnHeaders_Property_Std
strRet = "Property"


'' status strings
Case ResId.lblStatus_Caption_GatheringData
strRet = "Gathering data of " & arrParams(0) & " elements:"
Case ResId.lblStatus_Caption_FindingDuplicates
strRet = "Looking for duplicates: "
Case ResId.lblStatus_Caption_Results
strRet = "Done: found " & arrParams(0) & " " & IIf(arrParams(0) = 1, "element", "elements") & " with duplicate items"
Case ResId.lblStatus_Caption_EmptyingCache
strRet = "Cleaning folder cache..."
Case ResId.lblCache_Caption_MemoryConsumption
strRet = "items in cache:" & vbNewLine & arrParams(0) & vbNewLine & "(ca. " & arrParams(1) & " MB)"

Case Else:
strRet = "###N/A###"
MsgBox "String with ResourceIndex==" & intResourceIndex & " not found!", vbCritical Or vbOKOnly
End Select

Language_English = strRet
End Function




Private Function Language_German(intResourceIndex As ResId, ByVal arrParams As Variant) As String
Dim strRet As String
strRet = Empty


Select Case intResourceIndex
'' Texte für grafische Oberfläche
Case ResId.lblFolderSelect_Caption_Std
strRet = "Ordner auswählen, in denen Duplikate gefunden werden sollen:" & vbNewLine & vbNewLine & "(Bereits gescannte Ordner im Cache werden automatisch durchsucht. Wählen Sie Ordner-Cache leeren, um dieses zu unterbinden.)"
Case ResId.cmdEmptyCache_Caption_Std
strRet = "Ordner-Cache leeren"
Case ResId.cmdFindDuplicates_Caption_Std
strRet = "Duplikate finden"
Case ResId.cmdFindDuplicates_Caption_Cancel
strRet = "Abbrechen"
Case ResId.cmdShowElement_Caption_Std
strRet = "Markiertes anzeigen"
Case ResId.cmdShowElement_ControlTipText_Std
strRet = "Öffnet die Detailansicht des markierten Elements"
Case ResId.cmdDeleteDuplicate_Caption_Std
strRet = "Markiertes löschen"
Case ResId.cmdDeleteDuplicate_ControlTipText_Std
strRet = "Verschiebt das markierte Duplikat in den Ordner ""Gelöschte Objekte"""
Case ResId.cmdDeleteChecked_Caption_Std
strRet = "Auswahl löschen"
Case ResId.cmdDeleteChecked_ControlTipText_Std
strRet = "Verschiebt alle ausgewählten Einträge in den Ordner ""Gelöschte Objekte"""
Case ResId.cmdClose_Caption_Std
strRet = "Schließen"
Case ResId.lvwDuplicates_ColumnHeaders_Subject_Std
strRet = "Betreff"
Case ResId.lvwDuplicates_ColumnHeaders_Folder_Std
strRet = "Ordner"
Case ResId.lvwDuplicates_ColumnHeaders_Property_Std
strRet = "Eigenschaft"

'' Status-Informationen
Case ResId.lblStatus_Caption_GatheringData
strRet = "Daten der " & arrParams(0) & " Elemente sammeln:"
Case ResId.lblStatus_Caption_FindingDuplicates
strRet = "Finden der Doppelungen: "
Case ResId.lblStatus_Caption_Results
strRet = "Fertig: " & arrParams(0) & " " & IIf(arrParams(0) = 1, "Element", "Elemente") & " mit Duplikaten gefunden"
Case ResId.lblStatus_Caption_EmptyingCache
strRet = "Ordner-Cache wird geleert..."
Case ResId.lblCache_Caption_MemoryConsumption
strRet = "Elemente im Cache:" & vbNewLine & arrParams(0) & vbNewLine & "(ca. " & arrParams(1) & " MB)"

Case Else:
strRet = Empty
End Select

Language_German = strRet
End Function

[gmayor]

I am not sure that helps, nor do I have any idea what any of this additional code has to do with the subject of the thread. The problem with the code is ResID and I have no idea what that relates to. It is not defined in your code.

[itmonitor]

I ran the code on Outlook. Here you have the screenshot, it seems the issue is with lvwDuplicates, or at least, when the error happens it will mark it in blue. 20176

[gmayor]

lvwDuplicates appears to relate to a function that does not exist in your code to be called, and you still have the issue of ResID.
You need to take this back to wherever you got the code from and check the instructions provided.
The code does not in any case appear to be connected to printing PDF attachments.

[itmonitor]

I managed to make it work on Outlook 2016 64 bit. It works seamlessly. The only issue is that no matter I create an Outlook Rule so the script will run only for one email account, it will print the pdf attachment from emails received on any from the 3 accounts I have in Outlook. Is there any code I can insert to limit running this VBA code to a specific email account?

[gmayor]

Did you select the account here?

20189

[itmonitor]

yes, please check attached image.

I tried both "through the specified account" and "to a person our group", setting the receiving person to the email account accountant(at)mydomain(dot)com. All pdf attachments emailed to this email account must be printed. It works.

But on further testing, it will also print pdf attachments emailed to the default email account default(at)mydomain(dot)com.

When I email a pdf to other email accounts, like for instance, support-tech(at)mydomain(dot)com and newsletter(at)mydomain.com, it will not print. (this is correct).

The Outlook rule was set only for the account accountant (at) mydomain (dot) com. All the other email accounts have zero rules setup on them.

Why the attachment will also print when emailed to default(at)mydomain.com?

Any help is appreciated.

20191