Outlook VBA: add category on open item

Is it possible in Microsoft Outlook开发者_开发百科 VBA to catch the Open event of any mail item that gets opened? I'd like to add a category label to any mail item I have opened, to have an alternative 'unread' option I could script against for something else. I've tried this:

Private Sub MailItem_Open()
    MsgBox "test"
End Sub

---

Perhaps something on the lines of:

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

The above should go in ThisOutlookSession. You will need to ensure that your security levels allow macros.

---

The accepted answer correctly identifies an opened email, but has an issue in that it will fail if there is another category that contains the one being added. For example if the category list contains Read Later as an entry, Read will not be added.

Additionally, the list separator is hard coded, when in fact Outlook uses the one set in regional settings.

To fix both these approaches you can use Split() to break the list up, search the list for the value, then Join() to put it back together. This can be done in conjunction with the correct list separator, as read from the registry.

Example code:

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