将带有指定附件的电子邮件从共享收件箱移动到同一共享邮箱的不同文件夹

Question

我创建了一个规则来对所有传入的电子邮件运行脚本。该脚本检查电子邮件是否有任何附件并检查其类型。只有 .pdf 附件的邮件保留在收件箱中，其余的进入错误文件夹。该脚本还会忽略隐藏的附件。

这适用于我自己的 Outlook 邮箱。问题是它必须在共享邮箱上工作。

我修改了规则，使其仅考虑到达共享邮箱的邮件，但它不起作用，即使我设置了没有任何脚本的规则。

我尝试更改脚本，但我唯一设法实现的是将无 pdf 的电子邮件从我的收件箱移动到共享收件箱中的错误文件夹。

这是适用于我自己邮箱的脚本：

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

我试过这个脚本，但它不起作用：

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

有两个问题：

1. 是否可以设置仅考虑到达共享收件箱的邮件的规则？当前规则仅检查到达我收件箱的电子邮件。 （我在规则管理中没有“将更改应用到此文件夹：”的选项。）
   如果不可能，我总是可以通过宏使脚本工作。

2. 代码应该怎么写？也许没关系，并且仅因为规则而不起作用。是否可以编写一个脚本来仅检查到达共享收件箱的邮件的附件？

Answer 1

@niton 建议使用 ItemAdd 并且它有效。现在脚本会检查共享收件箱中的电子邮件。

感谢您的帮助！

解决方案：

必须放在 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

我确信代码可以更优化，但“它可以正常工作”。