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.
by Allen Wyatt
(last updated May 25, 2013)
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.
Do More in Less Time! Are you ready to harness the full power of Word 2013 to create professional documents? In this comprehensive guide you'll learn the skills and techniques for efficiently building the documents you need for your professional and your personal life. Check out Word 2013 In Depth today!
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
Want to change the ToolTip that appears when you hover the mouse over a button on a toolbar? It's a bit more involved than ...Discover More
Need to use a macro to create a text string? One easy way to do it is to use the String function, described in this tip.Discover More
FREE SERVICE: Get tips like this every week in WordTips, a free productivity newsletter. Enter your address and click "Subscribe."
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.