Moving emails with specified attachments from shared inbox to a different folder of the same shared mailbox

Question

I created a rule to run a script on all incoming email. The script checks if the email has any attachments and checks their type. Mails which have only .pdf attachments, stay in the inbox, the rest goes to Error folder. The script also ignores hidden attachments.

This works on my own Outlook mailbox. The problem is that it has to work on a shared mailbox.

I modified the rule so it would take into consideration only the messages arriving at a shared mailbox, but it's not working, even if I set up a rule without any script.

I tried to change the script, but the only thing I managed to achieve is moving the pdf-less emails from my inbox to Error folder in shared inbox.

Here is the script that works with my own mailbox:

Sub PDF(Item As Outlook.MailItem)
    Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

    Dim myAtt As Outlook.Attachment
    Dim allPdf As Boolean
    Dim hidNum As Integer
    allPdf = True
    hidNum = 0
    Dim pa As PropertyAccessor

    For Each myAtt In Item.Attachments
        Debug.Print myAtt.DisplayName
        Set pa = myAtt.PropertyAccessor

        If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
            hidNum = hidNum + 1
        Else
            If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
                allPdf = False
            End If
        End If
    Next

    If allPdf = False Or Item.Attachments.Count = hidNum Then
        Item.Move Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Error")
    End If

    Set myAtt = Nothing
    Set pa = Nothing

End Sub

I tried this script, but it's not working:

Sub PDF4(Item As Outlook.MailItem)
    Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

    Dim myAtt As Outlook.Attachment
    Dim allPdf As Boolean
    Dim hidNum As Integer
    Dim myNamespace As Outlook.NameSpace
    Dim myRecipient As Outlook.Recipient

    Set myNamespace = Application.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient("[email protected]")

    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)

    strFolderName = objInbox.Parent

    Set objMailbox = objNamespace.Folders(strFolderName)
    Set objFolder = objMailbox.Folders(olFolderInbox)
    Set colItems = objFolder.Items

    allPdf = True
    hidNum = 0
    Dim pa As PropertyAccessor

    For Each Item In objFolder.Items
        For Each myAtt In Item.Attachments
            Debug.Print myAtt.DisplayName
            Set pa = myAtt.PropertyAccessor

            If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                hidNum = hidNum + 1
            Else
                If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
                    allPdf = False
                End If
            End If
        Next



    If allPdf = False Or Item.Attachments.Count = hidNum Then
        Item.Move objInbox.Folders("Error")
    End If

    Set myAtt = Nothing
    Set pa = Nothing

End Sub

There are two problems:

1. Is it possible to set up a rule that takes into consideration only the messages which arrive at the shared inbox? The current rule checks only the emails, which arrive at my inbox. (I have no option in Rule Management to "Apply changes to this folder:".)
   If not possible, I could always make the script work through macro.

2. How should the code be written? Maybe it's ok and is not working only because of the rule. Is it possible to make a script that checks the attachments only of the messages that arrive at the shared inbox?

Answer 1

@niton suggested using ItemAdd and it worked. Now the script checks emails in shared inbox.

Thank you for help!

Solution:

It has to be put inside ThisOutlookSession

Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items

Private Sub Application_Startup()

Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("[email protected]")

Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)
Set objItems = objWatchFolder.Items

Set objWatchFolder = Nothing
Set Recip = Nothing
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer

allPdf = True
hidNum = 0

Dim pa As PropertyAccessor

Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("[email protected]")

Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)

For Each myAtt In Item.Attachments
        Debug.Print myAtt.DisplayName
        Set pa = myAtt.PropertyAccessor

        If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
                hidNum = hidNum + 1
            Else
                If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
                    allPdf = False
                End If
            End If
    Next

    If allPdf = False Or Item.Attachments.Count = hidNum Then
        Item.Move objWatchFolder.Parent.Folders("Error")
    End If


Set Item = Nothing
Set myAtt = Nothing
Set pa = Nothing
Set objWatchFolder = Nothing
Set Recip = Nothing

End Sub

I'm sure the code could be more optimized, but "it just works".