Добавьте категорию для всех выбранных писем с помощью Outlook VBA

Я пытаюсь добавить категорию к каждому электронному письму, выбранному в Outlook, с помощью VBA.

Проблема в том, что приведенный ниже код добавляет категорию только к первому электронному письму.

Я использую 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