Run script on one of multiple email addresses

[bryceantony]

Hey there,

I am running a script to print PDF attachments, which works very well.

However, there are 2 email addresses in use (reception(at)someemail(dot)com and admin(at)someemail(dot)com)

The script prints PDF attachments sent to either of the accounts, and I would like to just print PDF attachments sent to admin(at)someemail(dot)com

The code that I am using is:


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

Public 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:\Temp_PDF_Print"

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


I suspect the issue is NameSpace.GetDefaultFolder returns the default folder on the default store for the current profile, therefore printing all PDF attachments from both of the email addresses.

How do I change this to only print PDF attachments sent to admin(at)someemail(dot)com?

Any help is much appreciated.
Thank you :-)

[gmayor]

I am not sure how it worked correctly when you had

sDirectory = "C:\Temp_PDF_Print"
'rather than
sDirectory = "C:\Temp_PDF_Print\"
'and
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
The simplest approach to this is to use the script (slightly modified and in a normal module rather than ThisOutlookSession) to run from a rule that checks all incoming mail to admin(at)someemail(dot)com as it arrives in the inbox. If the Scripts option is missing from the rules, then see https://www.slipstick.com/outlook/rules/outlook-run-a-script-rules/
I would suggest creating the temporary file on the desktop then delete it after printing.
The modified code also works on 64 bit Office.


Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As LongPtr) As LongPtr
#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


Public 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


If TypeName(oMail) = "MailItem" Then
sDirectory = Environ("USERPROFILE") & "\Desktop\"


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 = sDirectory & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End If
Set colAtts = Nothing
Set oAtt = Nothing
Set oMail = Nothing
End Sub