如何让Outlook的olSentItems_ItemAdd事件支持所有账户发送邮件时触发？

现有Outlook VBA代码仅在使用默认账户发送邮件时触发，想要修改为任意账户发送邮件后都触发执行，原代码如下：

Private Sub olSentItems_ItemAdd(ByVal Item As Object)

On Error Resume Next

Dim strPrompt As String

strPrompt = "Do you want to flag this message for followup?"

If MsgBox(strPrompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Add flag?") = vbYes Then

    Dim strDays As String
    Dim intDays As Integer
    Dim strFollowMessage As String
    Dim dteDue As Date

    strDays = InputBox("Days?", , 3)


    intDays = Val(strDays)

    strFollowMessage = InputBox("Message?", , "PRH FollowUp")

    With Item

        .IsMarkedAsTask

        .MarkAsTask olMarkNoDate

        dteDue = Now + intDays

        .TaskDueDate = dteDue
        .TaskStartDate = dteDue
        .FlagRequest = strFollowMessage
        .ReminderSet = False

        .Save

    End With

End If

End Sub

解决方案 #

要监听所有账户的已发送文件夹，需通过类模块为每个账户的已发送文件夹绑定事件，具体步骤如下：

1. 创建类模块 #

• 打开Outlook VBA编辑器（按Alt+F11）
• 右键点击项目资源管理器，选择「插入」→「类模块」
• 在属性窗口将类模块名称改为clsSentFolderListener
• 在类模块中粘贴以下代码：

Public WithEvents SentFolder As Outlook.Folder

Private Sub SentFolder_ItemAdd(ByVal Item As Object)
    On Error Resume Next

    Dim strPrompt As String
    strPrompt = "Do you want to flag this message for followup?"

    If MsgBox(strPrompt, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Add flag?") = vbYes Then
        Dim strDays As String
        Dim intDays As Integer
        Dim strFollowMessage As String
        Dim dteDue As Date

        strDays = InputBox("Days?", , 3)
        intDays = Val(strDays)
        strFollowMessage = InputBox("Message?", , "PRH FollowUp")

        With Item
            .MarkAsTask olMarkNoDate
            dteDue = Now + intDays
            .TaskDueDate = dteDue
            .TaskStartDate = dteDue
            .FlagRequest = strFollowMessage
            .ReminderSet = False
            .Save
        End With
    End If
End Sub

2. 修改ThisOutlookSession模块 #

• 打开ThisOutlookSession模块
• 粘贴以下代码：

Dim colSentListeners As New Collection

Private Sub Application_Startup()
    InitializeAllSentFolders
End Sub

Private Sub InitializeAllSentFolders()
    Dim ns As Outlook.NameSpace
    Dim acc As Outlook.Account
    Dim sentFolder As Outlook.Folder
    Dim listener As clsSentFolderListener

    Set ns = Application.GetNamespace("MAPI")

    ' 遍历所有账户
    For Each acc In Application.Accounts
        ' 获取当前账户的已发送文件夹
        Set sentFolder = ns.GetDefaultFolder(olFolderSentMail).Parent.Folders(acc.SmtpAddress).Folders("已发送邮件")
        ' 创建监听器实例并绑定文件夹
        Set listener = New clsSentFolderListener
        Set listener.SentFolder = sentFolder
        ' 将实例加入集合，防止被垃圾回收
        colSentListeners.Add listener
    Next acc

    Set ns = Nothing
End Sub

3. 注意事项 #

• 若你的Outlook是英文版本，需将代码中的"已发送邮件"改为"Sent Items"
• 修改完成后，重启Outlook使设置生效
• 集合colSentListeners必须声明为全局变量，否则类实例会被自动回收，导致事件失效

内容的提问来源于stack exchange，提问作者missedbeat