Macro : Pour lister et visualiser toutes les polices installées

Sub ListFonts()
    ' Objectif    : Lister et illustrer toutes les polices installées.
    ' Utilisation : Attention le génération peut être assez longue s'il y a beaucoup de police !
    ' Retour      : Nouveau document Word.
    ' Appels      : - TriQuick > Permettant de trier un tableau.
    ' Auteur      : Arnaud (www.1forme.fr).
    ' Licence     : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les même conditions,
    '                           seulement à titre personnel et citant l'auteur/site d'origine.  
    
    Dim varFont         ' Variant obligatoire
    Dim objPara         As Paragraph
    Dim intCpt          As Integer
    Dim strTabPolices()
    Dim i               As Integer
    
    Application.ScreenUpdating = False
    ReDim strTabPolices(1 To FontNames.Count)
    ' Alimentation du tableau
    For i = 1 To FontNames.Count
        strTabPolices(i) = FontNames(i)
    Next
    ' Tri du tableau
    Call TriQuick(strTabPolices, 1, FontNames.Count, True)
    ' Création du document
    Documents.Add Template:="normal"
    ActiveDocument.Paragraphs(1).Range.Text = "Liste des polices installées" & " (" & FontNames.Count & ")"
    
    For Each varFont In strTabPolices
        intCpt = intCpt + 1
        Set objPara = ActiveDocument.Paragraphs.Add.Next
        ' Ligne de titre (Nom de la police)
        objPara.SpaceBefore = 10
        objPara.SpaceAfter = 0
        With objPara.Range
            .Font.Name = "Times New Roman"
            .Font.Bold = True
            .Font.Underline = True
            .Text = varFont & " (" & intCpt & ")"
        End With
        Set objPara = ActiveDocument.Paragraphs.Add.Next
        objPara.SpaceBefore = 0
        objPara.SpaceAfter = 0
        With objPara.Range
            ' Génération de deux lignes d'illustration (Lettres et Chiffres/symboles)
            .Font.Bold = False
            .Font.Underline = False
            .Font.Name = varFont
            .Text = "aàâbcçdeéèêëfghiîïjklmnoôöpqrstuùûüvwxyz" & vbCrLf & "0123456789 &{}()[]@=+*/€$£µ%!?,;:§" 'Exemple de texte
        End With
    Next
    ActiveDocument.Paragraphs(1).Alignment = wdAlignParagraphCenter
    Application.ScreenUpdating = True
End Sub

Sub TriQuick(a(), dbDebut As Long, dbFin As Long, boOrdre As Boolean)
    ' Objectif    : Trier un tableau
    '               Basé sur le code de Jacques Boigontier il me semble
    Dim lgG As Long, lgD As Long
    Dim varRef ' Val triée num/alpha-num
    
    varRef = a((dbDebut + dbFin) \ 2)
    lgG = dbDebut: lgD = dbFin
    Do
      If boOrdre Then
          Do While a(lgG) < varRef: lgG = lgG + 1: Loop
          Do While varRef < a(lgD): lgD = lgD - 1: Loop
      Else
          ' Tri décroissant
           Do While a(lgG) > varRef: lgG = lgG + 1: Loop
           Do While varRef > a(lgD): lgD = lgD - 1: Loop
      End If
      If lgG <= lgD Then
        temp = a(lgG): a(lgG) = a(lgD): a(lgD) = temp
        lgG = lgG + 1: lgD = lgD - 1
      End If
    Loop While lgG <= lgD
    If lgG < dbFin Then Call TriQuick(a, lgG, dbFin, boOrdre)
    If dbDebut < lgD Then Call TriQuick(a, dbDebut, lgD, boOrdre)
End Sub