☰

Outlook VBA - 启动宏，用于移动多个共享收件箱的传入无法送达（NDR 类）邮件

tag-icon • tag-icon microsoft-outlook vba visual-basic shared-mailbox
Outlook VBA - 启动宏，用于移动多个共享收件箱的传入无法送达（NDR 类）邮件

我对 Java 有一点经验，但对 Visual Basic 几乎没有经验。我需要为我的 Outlook 创建一个宏，该宏在配置文件中有 4 个收件箱。其中一个是我的[电子邮件保护]，另一个是[电子邮件保护]，一个用于信息，一个用于每月报表。我在这里已经看到了一个针对 NDR 类消息的解决方案，似乎对某些人有用（是否可以根据邮件类别在 Outlook 2010 中设置规则？)。但是，它对我和共享相同收件箱的同事不起作用。基本上，我们所有人都负责维护 3 个收件箱加上我们自己的收件箱，并且我们收到大量无法送达的回复。我们想将 NDR 类消息过滤到子文件夹中。有谁知道修改上述链接中的解决方案的方法，将所有收件箱过滤到信息收件箱下名为“NDR”的子文件夹中？

答案1

为四个收件箱分别创建一个监听器。

您可以测试主题​​中是否存在与您的未送达物品相关的独特文本。

在此 Outlook 会话中

Option Explicit

Private WithEvents defaultInboxItems As Items
Private WithEvents marketingItems As Items
Private WithEvents infoItems As Items
Private WithEvents monthlyStatementsItems As Items

Private Sub Application_Startup()
Set defaultInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
Set marketingItems = Session.folders("[email protected]").folders("Inbox").Items
Set infoItems = Session.folders("[email protected]").folders("Inbox").Items
Set monthlyStatementsItems = Session.folders("[email protected]").folders("Inbox").Items
End Sub


Private Sub defaultInboxItems_ItemAdd(ByVal Item As Object)

    Dim fldrS As folders
    Dim fldr As Folder

    Dim nonDeliverySubject As String
    Dim lenNonDeliverySubject As Long

    Debug.Print "Subject: " & Item.Subject

    ' If the start of subject of the non delivery message is "Mail System Error - Subject:"
    ' otherwise use what you receive

    nonDeliverySubject = "Mail System Error - Subject:"
    lenNonDeliverySubject = Len(nonDeliverySubject)

    Debug.Print "Left(UCase(Item.Subject), lenNonDeliverySubject): " & _
      Left(UCase(Item.Subject), lenNonDeliverySubject)

    ' It is safer to put UCase (or LCase) on both sides
    '  The unwary may type in the other case
    If Left(UCase(Item.Subject), lenNonDeliverySubject) = UCase(nonDeliverySubject) Then

        Set fldrS = Session.GetDefaultFolder(olFolderInbox).folders

        ' Bypass error, for a specific reason, if NDR folder does not exist
        On Error Resume Next
        Set fldr = fldrS.Item("NDR")
        ' Return to normal error handling immediately
        On Error GoTo 0

        If fldr Is Nothing Then
            Set fldr = fldrS.Add("NDR")
        End If

        Item.Move fldr

    End If

End Sub

Private Sub marketingInboxItems_ItemAdd(ByVal Item As Object)
    ' repeat the code for defaultInboxItems_ItemAdd
    ' with one change
    Set fldrS = Session.folders("[email protected]").folders("Inbox").folders
End Sub


Private Sub infoItems_ItemAdd(ByVal Item As Object)
    ' repeat the code for defaultInboxItems_ItemAdd
    ' with one change
    Set fldrS = Session.folders("[email protected]").folders("Inbox").folders
End Sub

Private Sub monthlyStatementsItems_ItemAdd(ByVal Item As Object)
    ' repeat the code for defaultInboxItems_ItemAdd
    ' with one change
    Set fldrS = Session.folders("[email protected]").folders("Inbox").folders
End Sub

REPORT.IPM.NOTE.NDR 的消息类别测试是否可以根据邮件类别在 Outlook 2010 中设置规则？可能不再有效。

要检查未送达邮件的消息类别：

Debug.Print "UCase(Item.MessageClass): " & UCase(Item.MessageClass)

相关内容