Question

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

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

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

我试图更改脚本，但是我唯一要实现的就是将无pdf格式的电子邮件从我的收件箱移到共享收件箱中的Error文件夹。

以下是可用于我自己的邮箱的脚本：

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

有两个问题：

是否可以设置仅考虑到达共享收件箱的邮件的规则？当前规则仅检查到达我的收件箱的电子邮件。（我在“规则管理”中没有选择“将更改应用于此文件夹：”。）
如果不可能的话，我总是可以使脚本通过宏工作。
应如何编写代码？也许还可以，并且仅由于该规则而不能正常工作。是否可以制作一个仅检查到达共享收件箱的邮件附件的脚本？

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

我确定代码可以进行更优化，但是“可以正常工作”。

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

1 个答案: