Sub Add_Category()
Dim olItem As Object
Dim Arr As Variant
Dim i As Integer
Const strCat As String = "TRIM"
    On Error GoTo err_Handler
    Set olItem = Application.ActiveExplorer.Selection.Item(1)
    If TypeName(olItem) = "MailItem" Then
        Arr = Split(olItem.Categories, ",")
        If UBound(Arr) >= 0 Then
            For i = 0 To UBound(Arr)
                If Trim(UCase(Arr(i))) = strCat Then
                    Beep
                    MsgBox "Already categorised with " & strCat
                    GoTo lbl_Exit
                End If
            Next
        End If
        olItem.Categories = strCat & "," & olItem.Categories
        olItem.Save
    End If
lbl_Exit:
    Set olItem = Nothing
    Exit Sub
err_Handler:
    Beep
    MsgBox "Select a message!"
    Err.Clear
    GoTo lbl_Exit
End Sub