Macro: List fonts within a text file?

Sub ListDocumentFonts()
    Dim p As Page
    Dim s As Shape
    Dim col As New Collection
    Dim sFontList As String
    Dim vFont As Variant
    
    For Each p In ActiveDocument.Pages
        For Each s In p.FindShapes(, cdrTextShape)
            FindFontsInRange s.Text.Frame.Range, col
        Next s
    Next p
    
    sFontList = ""
    For Each vFont In col
        If sFontList <> "" Then sFontList = sFontList & vbCrLf
        sFontList = sFontList & vFont
    Next vFont
    ActiveDocument.Pages(1).ActiveLayer.CreateParagraphText 0, 0, 3, 8, sFontList, Font:="Arial", Size:=10
End Sub

Private Sub FindFontsInRange(ByVal tr As TextRange, ByVal col As Collection)
    Dim FontName As String
    Dim trBefore As TextRange, trAfter As TextRange
    FontName = tr.Font
    If FontName = "" Then
        ' There are more than one font in the range
        ' Divide the range in two and look into each half separately
        ' to see if any of them has the same font. Repeat recursively
        Set trBefore = tr.Duplicate
        trBefore.End = (trBefore.Start + trBefore.End) \ 2
        Set trAfter = tr.Duplicate
        trAfter.Start = trBefore.End
        FindFontsInRange trBefore, col
        FindFontsInRange trAfter, col
    Else
        AddFontToCollection FontName, col
    End If
End Sub

Private Sub AddFontToCollection(ByVal FontName As String, ByVal col As Collection)
    Dim v As Variant
    Dim bFound As Boolean
    
    bFound = False
    For Each v In col
        If v = FontName Then
            bFound = True
            Exit For
        End If
    Next v
    
    If Not bFound Then col.Add FontName
End Sub