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.
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.
Learn more about Allen...
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.
Learning Made Easy! Quickly teach yourself how to format, publish, and share your content using Word 2013. With Step by Step, you set the pace, building and practicing the skills you need, just when you them! Check out Microsoft Word 2013 Step by Step today!