Dim oStore As Outlook.Store
Private Sub GetCategoryNamesinAllAccounts()
    Dim oStores As Outlook.Stores
    Dim oCategories As Outlook.Categories
    Dim oCategory As Outlook.Category
    Dim strOutput As String
    Dim i As Variant
    Set oStores = Application.Session.Stores
 
    For Each oStore In oStores
        Set oCategories = oStore.Categories

        If oCategories.Count > 1 Then
        For i = oCategories.Count To 1 Step -1
          Set oCategory = oCategories(i)
             strOutput = strOutput & "AddCategory " & Chr(34) & oCategory.Name & Chr(34) & ", " & oCategory.Color & ", " & oCategory.ShortcutKey & vbCrLf
           oCategories.Remove (oCategory.CategoryID)
        Next i
        End If
     
        strOutput = oStore.DisplayName & vbCrLf _
        & "--------------Categories-----------------" & vbCrLf _
        & strOutput
        Debug.Print strOutput

		Open "C:\Users\Diane\my-cats.txt" For Append As 1
		Print #1, strOutput
		Close #1
        strOutput = ""

    Next

 Set oStores = Nothing
 Set oStore = Nothing
 Set oCategories = Nothing
 Set oCategory = Nothing
 
End Sub

Sub AddCategoriesToAllStores()
    Dim colStores As Outlook.Stores
    On Error Resume Next
    Set colStores = Application.Session.Stores
    For Each oStore In colStores

' for all accounts
   AddCategory "Anniversary", 6, 0

'for individual accounts
If oStore.DisplayName = "me@mydomain.com" Then

   AddCategory "cat1", 8, 0
   AddCategory "cat2", 10, 0

End If

    Next
End Sub


Private Sub AddCategory(strCategoryName As String, intColor As Integer, intKey As Integer)
       On Error Resume Next
    oStore.Categories.Add strCategoryName, intColor, intKey
    Set objNS = Nothing
End Sub