![Outlook VBA - 启动宏,用于移动多个共享收件箱的传入无法送达(NDR 类)邮件](https://linux22.com/image/1616187/Outlook%20VBA%20-%20%E5%90%AF%E5%8A%A8%E5%AE%8F%EF%BC%8C%E7%94%A8%E4%BA%8E%E7%A7%BB%E5%8A%A8%E5%A4%9A%E4%B8%AA%E5%85%B1%E4%BA%AB%E6%94%B6%E4%BB%B6%E7%AE%B1%E7%9A%84%E4%BC%A0%E5%85%A5%E6%97%A0%E6%B3%95%E9%80%81%E8%BE%BE%EF%BC%88NDR%20%E7%B1%BB%EF%BC%89%E9%82%AE%E4%BB%B6.png)
我对 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)