Outlook VBA：在未清项目上添加类别答案

【问题标题】：Outlook VBA: add category on open itemOutlook VBA：在未清项目上添加类别
【发布时间】：2020-06-24 17:47:46
【问题描述】：

是否可以在 Microsoft Outlook VBA 中捕获任何打开的邮件项目的打开事件？我想为我打开的任何邮件项目添加一个类别标签，以便有一个替代的“未读”选项，我可以针对其他内容编写脚本。我试过这个：

Private Sub MailItem_Open()
    MsgBox "test"
End Sub

【问题讨论】：

标签： vba outlook

【解决方案1】：

也许是这样的：

Public WithEvents myOlInspectors As Outlook.Inspectors
Public myInspectorsCollection As New Collection

Private Sub Application_Startup()
    Initialize_handler
End Sub

Public Sub Initialize_handler()
    Set myOlInspectors = Application.Inspectors
End Sub

Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
If (Inspector.CurrentItem.Class = olMail) Then

    If Inspector.CurrentItem.Parent = "Inbox" Then
        strCats = Inspector.CurrentItem.Categories

        If InStr(strCats, "Read") = 0 Then
            If Not strCats = vbNullString Then
                strCats = strCats & ","
            End If
            strCats = strCats & "Read"
            Inspector.CurrentItem.Categories = strCats
            Inspector.CurrentItem.Save
        End If
    End If
End If
End Sub

上面的内容应该放在 ThisOutlookSession 中。您需要确保您的安全级别允许使用宏。

【讨论】：

谢谢，我试图捕捉 ItemChange 事件，但我不知道 NewInspector 事件。它确实更适合。我添加了 If Inspector.CurrentItem.Parent.FolderPath = "\\Mailbox - support\Inbox" 然后将其限制为我打开的第二个邮箱。

【解决方案2】：

接受的答案正确地识别了一封打开的电子邮件，但存在一个问题，即如果有另一个类别包含正在添加的电子邮件，它将失败。例如，如果类别列表包含Read Later 作为条目，则不会添加Read。

此外，列表分隔符是硬编码的，而实际上 Outlook 使用区域设置中的一组分隔符。

要修复这两种方法，您可以使用Split() 分解列表，在列表中搜索值，然后使用Join() 将其重新组合在一起。这可以与从注册表中读取的正确列表分隔符一起完成。

示例代码：

Public WithEvents myOlInspectors As Outlook.Inspectors
Public myInspectorsCollection As New Collection

Private Sub Application_Startup()
    Initialize_handler
End Sub

Public Sub Initialize_handler()
    Set myOlInspectors = Application.Inspectors
End Sub

Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
    If (Inspector.CurrentItem.Class = olMail) Then
        If Inspector.CurrentItem.Parent = "Inbox" Then
            AddCategory Inspector.CurrentItem, "Read"
            Inspector.CurrentItem.Save
        End If
    End If
End Sub

Sub AddCategory(aMailItem As MailItem, newCategory As String)
    Dim categories() As String
    Dim listSep As String

    ' Get the current list separator from Windows regional settings
    listSep = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\International\sList")

    ' Break the list up into an array
    categories = Split(aMailItem.categories, listSep)

    ' Search the array for the new cateogry, and if it is missing, then add it
    If UBound(Filter(categories, newCategory)) = -1 Then
        ReDim Preserve categories(UBound(categories) + 1)
        categories(UBound(categories)) = newCategory
        aMailItem.categories = Join(categories, listSep)
    End If
End Sub

【讨论】：