Add a category for all selected emails using Outlook VBA

Question

I'm trying to add a category to every email selected in Outlook using VBA.

The problem is that the code below adds the category only to the first email.

I'm using Outlook 2016.

Public Sub MarkSelectedAsGreenCategory()
    Dim olItem As MailItem
    
    Dim newCategory As String
    newCategory = "Green category"
    
    Dim i As Integer
    
    For i = 1 To Application.ActiveExplorer.Selection.Count
        Set olItem = Application.ActiveExplorer.Selection(i)
        AddCategory olItem, newCategory
        Set olItem = Nothing
    Next
      
End Sub

Private Sub AddCategory(mailItem 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(mailItem.categories, listSep)

    ' Search the array for the new category, 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
        mailItem.categories = Join(categories, listSep)
    End If
End Sub

Answer 1

An update to a category on ActiveInspector.CurrentItem would generate a prompt to save.

For a selection:

olItem.Save or mailItem.Save at your convenience.

Answer 2

Here is the corresponding code for removing a category:

Public Sub RemoveCategory(mailItem As mailItem, oldCategory 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(mailItem.categories, listSep)

    ' Search the array for the new category, and if it is present, then remove it
    If UBound(Filter(categories, oldCategory, True, vbTextCompare)) <> -1 Then
        categories = Filter(categories, oldCategory, False, vbTextCompare)
        mailItem.categories = Join(categories, listSep)
    End If
End Sub