Solution : en écrivant une macro en VBA.

Sous Windows, il n’existe pas de fonction pour imprimer la liste de toutes les polices de caractères installées sur le système. Si vous disposez de Word, vous pouvez écrire une macro qui affiche la liste des fontes.

Pour cela, cliquez sur le menu Outils et choisissez successivement les commandes Macro et Visual Basic Editor. Optez pour la commande Module du menu Insertion. Recopiez le listing ci-dessous. 
Cliquez sur l’icône Enregistrer représentant une disquette, dans la barre d’outils, puis optez pour la commande Fermer et retourner à Microsoft Word du menu Fichier.
Ce programme crée un nouveau document dans lequel il insère un exemple de texte auquel il affecte une police de caractères, puis le nom de cette dernière, le tout sur une même ligne. Pour lancer ListePolicesInstallées, appuyez sur la combinaison de touches +. Sélectionnez ListePolicesInstallées. Validez par un clic sur le bouton [Exécuter].Ensuite, cliquez sur licône Aperçu avant Impression. Ajustez éventuellement les options de mise en page, telles que les marges ou les dimensions de la feuille et imprimez le document via la commande Imprimer du menu Fichier.Listing :

sub ListePolicesInstallées()
Documents.Add
For Each PolicesCar In FontNames
With Selection
.InsertAfter “Ex : servez un whisky au juge blond qui fume la pipe”
.Font.Name = PolicesCar
.Font.Size = 10
.InsertAfter vbTab & PolicesCar & vbCrLf
.MoveStartUntil vbTab
.Font.Name = “Arial”
.MoveDown wdParagraph, 1
End With
Next
End Sub

public Sub ListePolice()
'macro écrite par anacoluthe
Dim MaListe, sFont
For Each sFont In FontNames
With ActiveDocument.Content.Find
.ClearFormatting
.Format = True
.Text = ""
.Font.Name = sFont
If .Execute() Then
MaListe = MaListe & sFont & vbCr
End If
End With
Next sFont
MsgBox MaListe
End Sub

---------------------------------
Sub ListFont()
   Dim nom As String, Ligne As Long
   Ligne = 1
   nom = Dir("\windows\fonts\*.*")
   While Len(nom) > 0
      Cells(Ligne, 1).Value = nom
      Ligne = Ligne + 1
      nom = Dir()
   Wend
End Sub

-----------------------------------
Dim ligne
Sub arborescence()
  Application.ScreenUpdating = False
  racine = "C:\Windows\Fonts"
  If racine = "" Then Exit Sub
  Range("A1:E20000").ClearContents
  Range("A1").Select
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = 1
  Lit_dossier dossier_racine, 1
End Sub
Sub Lit_dossier(ByRef dossier, ByVal niveau)
   Cells(ligne, 1) = String(4 * (niveau - 1), " ") & "[" & dossier.Path & "]"
   Cells(ligne, 1).Interior.ColorIndex = 36
   ligne = ligne + 1
   For Each f In dossier.Files
     Cells(ligne, 1) = String(4 * niveau, " ") & f.Name
     Cells(ligne, 1).Interior.ColorIndex = xlNone
     ligne = ligne + 1
   Next
   For Each d In dossier.SubFolders
     Lit_dossier d, niveau + 1
   Next
End Sub