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("test@mailbox.com")
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:
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.
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?
@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("test@mail.com")
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("test@mail.com")
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".
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.