Sub FontLister()
' Paul Beverley - Version 07.04.21
' Lists all font names in selected text or whole file

' stopWhenFound = True
stopWhenFound = False

myFileTitle = "Fonts list"

If Selection.Start = Selection.End Then
  doAll = True
  Set rng = ActiveDocument.Content
Else
  doAll = False
  Set rng = Selection.Range.Duplicate
End If

CR = vbCr
fontList = CR
If doAll = True Then
  For Each myPar In rng.Paragraphs
    nm = myPar.Range.Font.Name
    If nm > "" Then
      If InStr(fontList, nm) = 0 Then
        fontList = fontList & nm & CR
        If stopWhenFound = True Then myPar.Range.Select: MsgBox nm
      End If
    Else
      For Each wd In myPar.Range.Words
        nm = wd.Font.Name
        If nm > "" Then
          If InStr(fontList, nm) = 0 Then
            fontList = fontList & nm & CR
            If stopWhenFound = True Then
              wd.Select
              MsgBox nm
            End If
          End If
        Else
          For Each ch In wd.Characters
            nm = ch.Font.Name
            If InStr(fontList, nm) = 0 Then
              fontList = fontList & nm & CR
              If stopWhenFound = True Then ch.Select: MsgBox nm
            End If
          Next ch
        End If
      Next wd
    End If
    DoEvents
  Next myPar
  Documents.Add
  Selection.HomeKey Unit:=wdStory
  Selection.TypeText CR
  Selection.TypeText fontList
  Selection.Start = 0
  Selection.Sort SortOrder:=wdSortOrderAscending
  Selection.HomeKey Unit:=wdStory
  Selection.TypeText myFileTitle
  ActiveDocument.Paragraphs(1).Range.Style = wdStyleHeading2
Else
  For Each ch In rng.Characters
    nm = ch.Font.Name
    If InStr(fontList, nm) = 0 Then fontList = fontList & nm & CR
  Next ch
  MsgBox fontList
End If
End Sub