VBA-Code zum Drucken aller in Word installierten Schriftarten (alphabetisch)

Da will man "mal eben" eine Übersicht über alle Schriftarten, die in Office installiert sind haben und dann dauert es doch länger, weil es kein Skript gibt, das das alphabetisch macht. Hier ist jetzt eins :) Mit Alt + F11 den VBA-Editor öffnen, neues Modul einfügen und dann den Text hier nehmen.

 'Zeige alle Schriften alphabetisch  
 Sub SortDictionaryByKey()  
   'Set a reference to Microsoft Scripting Runtime by using  
   'Tools > References in the Visual Basic Editor (Alt+F11)  
   'Declare the variables  
   Dim Dict As Scripting.Dictionary  
   Dim TempDict As Scripting.Dictionary  
   Dim KeyVal As Variant  
   Dim Arr() As Variant  
   Dim Temp As Variant  
   Dim Txt As String  
   Dim i As Long  
   Dim j As Long  
   'Beispieltext  
   strText = "Der TEXT wird angezeigt pro Schrifftart"  
   'Create an instance of the Dictionary  
   Set Dict = CreateObject("Scripting.Dictionary")  
   'Set the comparison mode to perform a textual comparison  
   Dict.CompareMode = TextCompare  
   'Add keys and items to the Dictionary  
   For iFont = 1 To FontNames.Count  
     Dict.Add FontNames(iFont), iFont  
   Next  
   'Allocate storage space for the dynamic array  
   ReDim Arr(0 To Dict.Count - 1)  
   'Fill the array with the keys from the Dictionary  
   For i = 0 To Dict.Count - 1  
     Arr(i) = Dict.Keys(i)  
   Next i  
   'Sort the array using the bubble sort method  
   For i = LBound(Arr) To UBound(Arr) - 1  
     For j = i + 1 To UBound(Arr)  
       If Arr(i) > Arr(j) Then  
         Temp = Arr(j)  
         Arr(j) = Arr(i)  
         Arr(i) = Temp  
       End If  
     Next j  
   Next i  
   'Create an instance of the temporary Dictionary  
   Set TempDict = CreateObject("Scripting.Dictionary")  
   'Add the keys and items to the temporary Dictionary,  
   'using the sorted keys from the array  
   For i = LBound(Arr) To UBound(Arr)  
     KeyVal = Arr(i)  
     TempDict.Add Key:=KeyVal, Item:=Dict.Item(KeyVal)  
   Next i  
   'Set the Dict object to the TempDict object  
   Set Dict = TempDict  
   'Build a list of keys and items from the original Dictionary  
   For i = 0 To Dict.Count - 1  
     'Debug.Print Dict.Keys(i) & vbTab & Dict.Items(i)  
     iFont = Dict.Items(i)  
     strFontName = FontNames(iFont)  
     Selection.Font.Name = "Arial"  
     Selection.Font.Size = 8  
     Selection.TypeText Text:=strFontName  
     Selection.TypeText Text:=vbNewLine & vbTab & vbTab & vbTab  
     Selection.Font.Size = 12  
     Selection.Font.Name = strFontName  
     Selection.TypeText Text:=strText  
     Selection.TypeParagraph  
   Next i  
 End Sub