Question

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

Private Sub MailItem_Open()
    MsgBox "test"
End Sub

Answer 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中。您需要确保您的安全级别允许宏。

Answer 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

Outlook VBA：在打开的项目上添加类别

2 个答案: