Run script on one of multiple email addresses

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:

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
 
  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 :-)

I am not sure how it worked correctly when you had

Code:

---

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/ru...-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.

Code:

---

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

---