Please Note: This article is written for users of the following Microsoft Word versions: 97, 2000, 2002, and 2003. If you are using a later version (Word 2007 or later), this tip may not work for you. For a version of this tip written specifically for later versions of Word, click here: Creating a Document Font List.

Creating a Document Font List

by Allen Wyatt
(last updated May 25, 2013)

7

Word allows you to use the fonts that are installed on the system you are using. Fonts are installed within Windows, so that they are available not just to Word, but to all programs installed on your system.

When you are creating a document on your system, it is easy to know what fonts are being used—the list of fonts is limited to those available on the system. If you receive a document from a different person, however, the other person's system may have different fonts installed than you do. This means that their Word document could be formatted with fonts you don't even have on your system.

If you want to generate a list of fonts used within a document (as opposed to a list of fonts available on a system), you have a couple of choices. First of all, you can open the Word document in a text editor and look around in the parts of the document you don't normally see in Word. Near the end of the file you should see a list of fonts used in the document. If you do this, however, you should be very careful to not make any changes to the Word document while it is open in your text editor. Doing so can easily make the document no longer usable in Word.

A Word-based solution is to simply look through each character in a document and check out what font is used to format the character. A character-by-character approach is necessary because each character could be formatted with a different font, and VBA doesn't allow you to access a fonts collection in relation to the document itself—it seems that no such collection is maintained. Thus, the safest (and slowest) method is to simply step through each character and create your own list. The following VBA macro accomplishes the task:

Public Sub ListFontsInDoc1()
  Dim FontList(199) As String
  Dim FontCount As Integer
  Dim FontName As String
  Dim J As Integer, K As Integer, L As Integer
  Dim X As Long, Y As Long
  Dim FoundFont As Boolean
  Dim rngChar As Range
  Dim strFontList As String

  FontCount = 0
  X = ActiveDocument.Characters.Count
  Y = 0
  ' For-Next loop through every character
  For Each rngChar In ActiveDocument.Characters
    Y = Y + 1
    FontName = rngChar.Font.Name
    StatusBar = Y & ":" & X
    ' check if font used for this char already in list
    FoundFont = False
    For J = 1 To FontCount
      If FontList(J) = FontName Then FoundFont = True
    Next J
    If Not FoundFont Then
      FontCount = FontCount + 1
      FontList(FontCount) = FontName
    End If
  Next rngChar

  ' sort the list
  StatusBar = "Sorting Font List"
  For J = 1 To FontCount - 1
    L = J
    For K = J + 1 To FontCount
      If FontList(L) > FontList(K) Then L = K
    Next K
    If J <> L Then
      FontName = FontList(J)
      FontList(J) = FontList(L)
      FontList(L) = FontName
    End If
  Next J

  StatusBar = ""
  ' put in new document
  Documents.Add
  Selection.TypeText Text:="There are " & _
   FontCount & " fonts used in the document, as follows:"
  Selection.TypeParagraph
  Selection.TypeParagraph
  For J = 1 To FontCount
    Selection.TypeText Text:=FontList(J)
    Selection.TypeParagraph
  Next J
End Sub

Obviously, the longer your document, the longer it will take the macro to finish. (I ran the macro on an 1,100 page document and it took approximately 46 minutes. On a five-page document it took less than a minute.) When done, the macro creates a new document that contains a sorted list of the fonts used.

The above macro only steps through the main document. It is possible that there are other, different fonts used in other elements in your document. If you want those included in the list, then you need to use a variation on the macro that takes these other elements into account. The following macro (ListFontsInDoc2) is much longer, and the listing also includes three other macros that are called from within the main macro.

Public Sub ListFontsInDoc2()
  Dim rngStory As Word.Range
  Dim rngChar As Range
  Dim oShp As Word.Shape
  Dim FontName As String
  Dim lngIndex As Long
  Dim lngChar As Long
  Dim lngCharCount As Long
  Dim colFontsUsed As New Collection
  Dim oDocList As Word.Document

  For Each rngStory In ActiveDocument.StoryRanges
    lngChar = 0
    lngCharCount = rngStory.Characters.Count
    Do
      'Evaluate each character
      Set rngChar = rngStory.Characters(1)
      If rngStory.End > 1 Then
        Do
          lngChar = lngChar + 1
          FontName = rngChar.Font.Name
          StatusBar = "Evaluauting character " & lngChar & _
           " of " & lngCharCount & " characters in the story range"
          'Check if font used for this character already in list
          On Error Resume Next
          'Collection key prevents adding fonts already
          'in the collection
          colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
          On Error GoTo 0
          rngChar.MoveStart wdCharacter, 1
          rngChar.MoveEnd wdCharacter, 1
          'Set rngChar = rngChar.Next '
        Loop Until rngChar.End = rngStory.End
      End If

      'Evaluate shapes in headers and footers
      Select Case rngStory.StoryType
        Case 6, 7, 8, 9, 10, 11
          'No shape will throw an error that we handle and skip
          On Error GoTo Err_Handler
          If rngStory.ShapeRange.Count > 0 Then
            For Each oShp In rngStory.ShapeRange
              If oShp.TextFrame.HasText Then
                lngChar = 0
                lngCharCount = oShp.TextFrame.TextRange.Characters.Count
                For Each rngChar In oShp.TextFrame.TextRange.Characters
                  lngChar = lngChar + 1
                  FontName = rngChar.Font.Name
                  StatusBar = "Evaluauting character " & _
                   lngChar & " of " & lngCharCount & _
                   " characters in the story range"
                  On Error Resume Next
                  colFontsUsed.Add rngChar.Font.Name, rngChar.Font.Name
                  On Error GoTo 0
                Next rngChar
              End If
            Next oShp
          End If
        Case Else
          'Do Nothing
      End Select

SkipRange:
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next rngStory
  'Sort the collection.
  StatusBar = "Sorting Font List"
  Set colFontsUsed = SortCollection(colFontsUsed)
  StatusBar = ""
  'Create font list document.
  Set oDocList = Documents.Add
  With oDocList.Range
    .Text = "There are " & colFontsUsed.Count & _
     " fonts used in the document, as follows:" & vbCr & vbCr
    For lngIndex = 1 To colFontsUsed.Count
      .InsertAfter colFontsUsed(lngIndex) & vbCr
    Next lngIndex
  End With
  Set oDocList = Nothing
  Exit Sub

Err_Handler:
  Resume SkipRange
End Sub
Public Function SortCollection(ByVal oCol As Collection) As Collection
  Dim arrIndex() As Long
  Dim lngCount As Long
  Dim i As Long
  Dim m As Long
  Dim oColSorted As New Collection

  lngCount = oCol.Count
  If lngCount = 0 Then
    Set SortCollection = New Collection
    Exit Function
  End If

  'Allocate an index array.
  ReDim arrIndex(0 To lngCount - 1) As Long
  'Fill the index array.
  For i = 0 To lngCount - 1
    arrIndex(i) = i + 1
  Next i

  'Generate an ordered heap
  For i = lngCount/2 - 1 To 0 Step -1
    Heapify oCol, arrIndex, i, lngCount
  Next i

  'Sort the index array
  For m = lngCount To 2 Step -1
    Exchange arrIndex, 0, m - 1
    Heapify oCol, arrIndex, 0, m - 1
  Next
  For i = 0 To lngCount - 1
    oColSorted.Add oCol.Item(arrIndex(i))
  Next ' fill output collection
  Set SortCollection = oColSorted
End Function
Private Sub Heapify(oCol As Collection, arrIndexPasssed() As Long, _
 lngIndex As Long, lngCount As Long)
  Dim lngMidCount As Long
  Dim i As Long
  lngMidCount = lngCount/2

  Do While lngIndex < lngMidCount
    i = 2 * lngIndex + 1
    If i + 1 < lngCount Then
      If oCol.Item(arrIndexPasssed(i)) < oCol.Item(arrIndexPasssed(i + 1)) _
       Then i = i + 1
    End If
    If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) _
     Then Exit Do
    Exchange arrIndexPasssed, lngIndex, i
    lngIndex = i
  Loop
End Sub
Private Sub Exchange(Index() As Long, i As Long, j As Long)
  Dim Temp As Long
  Temp = Index(i)
  Index(i) = Index(j)
  Index(j) = Temp
End Sub

WordTips is your source for cost-effective Microsoft Word training. (Microsoft Word is the most popular word processing software in the world.) This tip (1522) applies to Microsoft Word 97, 2000, 2002, and 2003. You can find a version of this tip for the ribbon interface of Word (Word 2007 and later) here: Creating a Document Font List.

Author Bio

Allen Wyatt

With more than 50 non-fiction books and numerous magazine articles to his credit, Allen Wyatt is an internationally recognized author. He  is president of Sharon Parq Associates, a computer and publishing services company. ...

MORE FROM ALLEN

Turning Off Automatic Capitalization

Type some information into a worksheet, and you may notice that Excel automatically capitalizes some of your information. ...

Discover More

Exact Matches with DSUM

The DSUM function is very handy when you need to calculate a sum based on data that matches criteria you specify. If you ...

Discover More

Dragging to Clear Cells

If you want to get rid of the contents of a range of cells, a quick way to do it is with the Fill handle. Yes, you can use ...

Discover More

Comprehensive VBA Guide Visual Basic for Applications (VBA) is the language used for writing macros in all Office programs. This complete guide shows both professionals and novices how to master VBA in order to customize the entire Office suite for their needs. Check out Mastering VBA for Office 2010 today!

More WordTips (menu)

Determining the Horizontal Position of the Insertion Point

Need to figure out how far the insertion point is from the left margin? You can do so by using this small macro that relies ...

Discover More

Automatically Inserting Tomorrow's Date

Do you routinely need to work with tomorrow's date? Why not create a template that automatically adds tomorrow's date to any ...

Discover More

Calculating a Future Date

Need to figure out a date a certain number of days, weeks, months, or years in the future? It's easy to do using the DateAdd ...

Discover More
Subscribe

FREE SERVICE: Get tips like this every week in WordTips, a free productivity newsletter. Enter your address and click "Subscribe."

View most recent newsletter.

Comments

If you would like to add an image to your comment (not an avatar, but an image to help in making the point of your comment), include the characters [{fig}] in your comment text. You’ll be prompted to upload your image when you submit the comment. Images larger than 600px wide or 1000px tall will be reduced. Up to three images may be included in a comment. All images are subject to review. Commenting privileges may be curtailed if inappropriate images are posted.

What is seven more than 5?

2016-12-23 14:13:29

Ken Endacott

Display in the status line every thousandth character will speed thing up at the same time displaying progress.
If lngChar Mod 1000 = 0 Then
StatusBar = "Evaluauting character " & lngChar & _
" of " & lngCharCount & " characters in the story range"
End If


2016-12-22 20:17:10

Ryan Leach

To anyone using this, please note that you can speed it up a lot by deleting the status lines.

The least performant part is updating the status bar, the actual scanning for fonts is damn quick.


2016-04-05 08:04:55

Gé van Gasteren

I can gratefully report that the macro worked beautifully in my Word for Mac 2011 running on El Capitan and processed a 70-page document in about one minute.

(As the document has no footnotes, I’ve used only the first macro given.)

Thank you very much!


2015-12-17 06:16:05

Rajesh Bhat

Just what I was looking for!! Saved time and efforts. Thanks for sharing. Please note that this macro code considers the blank line also and lists that font too.


2015-06-05 22:25:47

Mark Harrison

Since this was VBA, I tried it in Excel, but it fails. Do you have a working version for Excel workbooks?

After opening the Excel document in Word, I was able to run the macros successfully. The first one returns Arial (from the Excel document) and Times (a final return added by Word in the process of opening the document). The second macro only returns Arial.

I also exported to PDF for comparison's sake. The PDF font list includes ArialMT, Arial-BoldMT and Arial-BoldItalicMT. This to me seems to be a more accurate and complete list. Could you adjust your macro to be this exact?

By the way, all of my work was donte on a Mac with Office 2004. Thank you for sharing this.


2013-11-27 06:49:57

Denis

Great piece of code!
I used it to check for some meaningless fonts in files from a client.

I also modified the code to give a list of all the characters in a doc so that I could troubleshoot some bugs in files from the same client.

Thanks so much!
Denis


2013-07-09 06:27:25

Alan Peters

Thanks for providing this macro. Unfortunately, when I run it, I get the following error:

Runtime error 9
Subscript out of range

If I debug the error I see that it has stopped on the line:

If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) _
Then Exit Do

in Sub Heapify

The status bar reads "Sorting Font list"

Would you have any idea what I am doing wrong here?

Thanks!


This Site

Got a version of Word that uses the menu interface (Word 97, Word 2000, Word 2002, or Word 2003)? This site is for you! If you use a later version of Word, visit our WordTips site focusing on the ribbon interface.

Newest Tips
Subscribe

FREE SERVICE: Get tips like this every week in WordTips, a free productivity newsletter. Enter your address and click "Subscribe."

(Your e-mail address is not shared with anyone, ever.)

View the most recent newsletter.