• July 17, 2017
    Announcement: New site design for Microsoft Community

    In July, Microsoft will roll out the first of ongoing site improvements aimed to modernize Microsoft Community and help customers get the most out of their community experience.

    • During the roll out period, you may see the old or new site design depending on your location

    • We expect the roll out to finish by 31 July

    Note: Past private message conversations will not move to the new site design. Please save any private messages you would like to keep.

     Learn more about the upcoming site improvements in this thread.

    Thank you for being part of Microsoft Community!


List fonts used in a particular document

JohannSwart asked on

Is there a way that one can determine which fonts are used in any particular document?

41 people had this question

Abuse history

The answered status icon Answer
Greg Maxey replied on



This may be a little faster (read tiny bit) as it uses a collection (vice an array) to store the used fonts. 

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

lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
  lngChar = 0
  lngCharCount = rngStory.Characters.Count
    'Evaluate each character.
    For Each rngChar In rngStory.Characters
      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 is already in the 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
    Next rngChar
    'Evaluated shaped 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
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
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
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
  End If
  If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) Then
    Exit Do
  End If
  Exchange arrIndexPasssed, lngIndex, i
  lngIndex = i
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


Best Regards,
Greg Maxey

For more help with Word visit:
4 people found this helpful

Abuse history

The answered status icon Answer
PamCaswell replied on

In a  web search, I found a macro from a source I've used before here:



And a possibly faster method here, which might be worth looking into (the code is way beyond my vba-reading skills):



Good luck,


Pamelia Caswell
4 people found this helpful

Abuse history

Most Helpful Reply
Guruprasad Ra replied on

Reveal formatting will help us in detail about the fonts as well as all the formatting applied on a particular document.

Press Shift + F1 button on the keyboard to enable the 'Reveal formatting' feature.



14 people found this helpful

Abuse history