Sub ListInstalledFonts()
Application.ScreenUpdating = False
Dim ListFont As Variant
With ActiveDocument.Characters
  For Each ListFont In FontNames
    With .Last
      .Font.Name = "Arial"
      .Font.Size = 12
      .Text = ListFont & Chr(11)
    End With
    With .Last
      .Font.Name = ListFont
      .InsertAfter "ABCDEFGHIJKLMNOPQRSTUVWXYZ ~!@#$%^&*()_+|<>?:{}" & Chr(11) & _
        "abcdefghijklmnopqrstuvwxyz `1234567890-=\,.;'[]" & vbCr
    End With
    With .Last
      .Font.Name = "Arial"
      .InsertAfter vbCr
    End With
  Next ListFont
End With
Application.ScreenUpdating = True
End Sub

Sub TestDocFonts()
Application.ScreenUpdating = False
Dim StrFnt As Variant, StrFnts As String, StrInFnt As String, StrNoFnt As String, Fnt As Font
For Each StrFnt In FontNames
  StrFnts = StrFnts & "'" & StrFnt
Next
StrFnts = StrFnts & "'"
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Format = True
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[!^13]{1,}"
    With .Replacement
      .ClearFormatting
      .Text = "^&"
      .Font.Hidden = True
    End With
    .Execute Replace:=wdReplaceAll
    .Text = "?"
    .Font.Hidden = True
    .Execute
  End With
  Do While .Find.Found
    Set Fnt = .Font
    With Fnt
      If InStr(StrFnts, "'" & .Name & "'") > 0 Then
        StrInFnt = StrInFnt & vbCr & .Name
      Else
        StrNoFnt = StrNoFnt & vbCr & .Name
      End If
    End With
    With .Duplicate.Find
      .Font.Hidden = True
      .Replacement.Font.Hidden = False
      .Font.Name = Fnt.Name
      .Execute Replace:=wdReplaceAll
      .Font.Name = Fnt.Name & Fnt.NameAscii
      .Execute Replace:=wdReplaceAll
      .Font.Name = ""
      .Font.NameAscii = Fnt.NameAscii
      .Execute Replace:=wdReplaceAll
    End With
    .Find.Execute
    DoEvents
  Loop
End With
Application.ScreenUpdating = True
MsgBox "The following fonts were found in the document, and on the system:" & StrInFnt
MsgBox "The following fonts were found in the document, but not on the system:" & StrNoFnt
End Sub