Macro: List fonts within a text file?


Is there a macro out there that when activated, will do the following?

1.) Create a new TXT file.

2.) List the name of all fonts used in the document

3.) Save the TXT file using the same name as what the current document is named to a specified directory.

4.) Close the TXT file.

Is there an existing macro that can do this or would this be a difficult thing to accomplish?


Jason Moore

  • You might already be aware of this, but I add this here as general information: One can go to File>Document Info, use checkboxes to set what information is shown, and then save that information to a text file. "Text statistics" includes a list of fonts used in the document.

    For a macro such as the one you describe, someone has already written some code that creates a font list. For output, that macro produces an Artistic Text object.

    See this thread on the Oberon Place forum. The code is from Alex Vakulenko, fixed by Shelby Moore.

    For future reference, in case that ever disappears:

    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
            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
Reply Children