List all outlook categories VBA macro

ListAllOutlookCategories.bas

Option Explicit

' This creates a file %TEMP%\Categories.xml that lists all categories in Outlook
Sub ListAllOutlookCategories()
    Dim theStores As stores
    Dim xmlStr As String
    xmlStr = xmlStr + "<CategoriesList>" & vbCrLf
    
    Set theStores = Session.stores
    
    Dim i
    
    For i = 1 To theStores.Count
        Dim theStore As Store
        Set theStore = theStores.Item(i)
        xmlStr = xmlStr & vbTab & "<Store"
        'Call addAttribute(xmlStr, "Application", theStore.Application)
        'Call addAttribute(xmlStr, "Categories", theStore.Categories)
        Call addAttribute(xmlStr, "Class", theStore.Class)
        Call addAttribute(xmlStr, "DisplayName", theStore.DisplayName)
        Call addAttribute(xmlStr, "ExchangeStoreType", theStore.ExchangeStoreType)
        Call addAttribute(xmlStr, "FilePath", theStore.FilePath)
        Call addAttribute(xmlStr, "IsCachedExchange", theStore.IsCachedExchange)
        Call addAttribute(xmlStr, "IsConversationEnabled", theStore.IsConversationEnabled)
        Call addAttribute(xmlStr, "IsDataFileStore", theStore.IsDataFileStore)
        Call addAttribute(xmlStr, "IsInstantSearchEnabled", theStore.IsInstantSearchEnabled)
        Call addAttribute(xmlStr, "IsOpen", theStore.IsOpen)
        Call addAttribute(xmlStr, "Parent", theStore.Parent)
        Call addAttribute(xmlStr, "PropertyAccessor", theStore.PropertyAccessor)
        Call addAttribute(xmlStr, "Session", theStore.Session)
        Call addAttribute(xmlStr, "StoreID", theStore.StoreID)
        xmlStr = xmlStr & ">" & vbCrLf
        
        Dim theCategories As Categories
        Set theCategories = theStore.Categories
        
        Dim j
        
        For j = 1 To theCategories.Count
            Dim theCategory As Category
            Set theCategory = theCategories.Item(j)
            xmlStr = xmlStr & vbTab & vbTab & "<Category"
            Call addAttribute(xmlStr, "Name", theCategory.Name)
            Call addAttribute(xmlStr, "CategoryID", theCategory.CategoryID)
            Call addAttribute(xmlStr, "CategoryBorderColor", theCategory.CategoryBorderColor)
            Call addAttribute(xmlStr, "CategoryGradientBottomColor", theCategory.CategoryGradientBottomColor)
            Call addAttribute(xmlStr, "CategoryGradientTopColor", theCategory.CategoryGradientTopColor)
            'Call addAttribute(xmlStr, "Class", theCategory.Class)
            Call addAttribute(xmlStr, "Color", theCategory.Color)
            'Call addAttribute(xmlStr, "Session", theCategory.Session)
            Call addAttribute(xmlStr, "ShortcutKey", theCategory.ShortcutKey)
            xmlStr = xmlStr & " />" & vbCrLf
        Next
        
        xmlStr = xmlStr & vbTab & "</Store>" & vbCrLf
        
    Next
    
    xmlStr = xmlStr + "</CategoriesList>" & vbCrLf
    
    ' Save to file
    Dim outputPath As String
    outputPath = Environ("Temp") & "\Categories.xml"
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(outputPath, True, True)

    oFile.Write xmlStr
    oFile.Close
    
    Dim fsT As Object
    Set fsT = CreateObject("ADODB.Stream")
    fsT.Type = 2 'Specify stream type - we want To save text/string data.
    fsT.Charset = "utf-8" 'Specify charset For the source text data.
    fsT.Open 'Open the stream And write binary data To the object
    fsT.WriteText xmlStr
    fsT.SaveToFile outputPath, 2 'Save binary data To disk
    
End Sub

Sub addAttribute(xmlStr, key, value)
    xmlStr = xmlStr & " " & key & "=""" & CleanupStr(value) & """"
End Sub

' https://stackoverflow.com/a/13936156
Function CleanupStr(strXmlValue) As String
 'description: Replace forbidden char. &'"<> by their Predefined General Entities
 'author:      Patrick Honorez - www.idevlop.com
   Dim sValue As String
   If IsNull(strXmlValue) Then
     CleanupStr = ""
   Else
     sValue = CStr(strXmlValue)
     sValue = Replace(sValue, "&", "&amp;") 'do ampersand first !
     sValue = Replace(sValue, "'", "&apos;")
     sValue = Replace(sValue, """", "&quot;")
     sValue = Replace(sValue, "<", "&lt;")
     sValue = Replace(sValue, ">", "&gt;")
     CleanupStr = sValue
   End If
End Function