Macro to List all Font & its size in a word document

I need a Macro to list all the font name & its size in a word file - & list them
This is required as per the Audit by the Project
Can the below Macro be fine tuned for the same. The Below Macro list all the fonts other than arial & give me the page number where the font is located in the 300 page document. I need to modify the macro to give me all the fonts & its size in the new macro
Sub FindAllFonts()
Dim lWhichFont As Long
Dim sTempName As String
Dim sBuffer As String
Dim newDoc As Document Dim p As Long
Application.ScreenUpdating = False
For lWhichFont = 1 To FontNames.Count
sTempName = FontNames(lWhichFont)
If sTempName <> "Arial" Then
p = FindThisFont(sTempName)
If p > 0 Then sBuffer = sBuffer & sTempName & " on page " & p & vbCrLf
End If
End If
Next lWhichFont
Set newDoc = Documents.Add
Selection.TypeText Text:=sBuffer
Application.ScreenUpdating = True
End Sub
Function FindThisFont(sName As String) As Long
Selection.HomeKey Unit:=wdStory
With Selection.Find
.Text = ""
.ClearFormatting
.Font.Name = sName
.Forward = True
.Format = True
If .Execute Then FindThisFont = Selection.Information(wdActiveEndPageNumber)
End If
End With
End Function

Something like this:

Code:

---

Sub FindAllFonts()
Dim lngFontIndex As Long
Dim strName As String
Dim strReturn As String
Dim oOutputDoc As Document
Dim oRng As Word.Range
Dim oCol As New Collection
Dim lngIndex As Long
Application.ScreenUpdating = False
For lngFontIndex = 1 To FontNames.Count
  strName = FontNames(lngFontIndex)
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Text = ""
    .ClearFormatting
    .Font.Name = strName
    .Forward = True
    .Format = True
    .Wrap = wdFindStop
    While .Execute
      oRng.Select
      On Error Resume Next
      If oRng.Font.Size = 9999999 Then
        For Each oChr In oRng.Characters
          oCol.Add strName & " - " & oRng.Font.Size, strName & " - " & oRng.Font.Size
        Next oChr
      Else
        oCol.Add strName & " - " & oRng.Font.Size, strName & " - " & oRng.Font.Size
      End If
      On Error GoTo 0
      oRng.Collapse wdCollapseEnd
      If oRng.End + 1 = ActiveDocument.Range.End Then GoTo NextFont
    Wend
  End With
NextFont:
Next lngFontIndex
Output:
For lngIndex = 1 To oCol.Count
  strReturn = strReturn & oCol(lngIndex) & vbCr
Next lngIndex
Set oOutputDoc = Documents.Add
oOutputDoc.Range.Text = strReturn
Application.ScreenUpdating = True
End Sub

---

Sir,
Thanks for the updated macro but The Output is not showing the Page no of the Fonts listed.

The Output is only showing the Font & its Size - not the page no where it is located.

You didn't say you wanted to list the page numbers. I don't know why yet, but this macro is not processing text that is formatted with Theme Heading or Body font.

Code:

---

Sub FindAllFonts()
Dim lngFontIndex As Long
Dim strName As String
Dim strReturn As String
Dim oOutputDoc As Document
Dim oRng As Word.Range
Dim oCol As New Collection
Dim lngIndex As Long
Dim oChr As Range
Application.ScreenUpdating = False
For lngFontIndex = 1 To FontNames.Count
  strName = FontNames(lngFontIndex)
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Text = ""
    .ClearFormatting
    .Font.Name = strName
    .Forward = True
    .Format = True
    .Wrap = wdFindStop
    While .Execute
      On Error Resume Next
      If oRng.Font.Size = 9999999 Then
        For Each oChr In oRng.Characters
          oCol.Add strName & " - " & oChr.Font.Size & " - page:" & oRng.Information(wdActiveEndPageNumber), _
            strName & " - " & oChr.Font.Size & " - page:" & oRng.Information(wdActiveEndPageNumber)
        Next oChr
      Else
        oCol.Add strName & " - " & oRng.Font.Size & " - page:" & oRng.Information(wdActiveEndPageNumber), _
          strName & " - " & oRng.Font.Size & " - page:" & oRng.Information(wdActiveEndPageNumber)
      End If
      On Error GoTo 0
      oRng.Collapse wdCollapseEnd
      If oRng.End + 1 = ActiveDocument.Range.End Then GoTo NextFont
    Wend
  End With
NextFont:
Next lngFontIndex
For lngIndex = 1 To oCol.Count
  strReturn = strReturn & oCol(lngIndex) & vbCr
Next lngIndex
Set oOutputDoc = Documents.Add
oOutputDoc.Range.Text = strReturn
Application.ScreenUpdating = True
End Sub

---

Sir,
The MAcro is working perfectly fine.
Thank you very much & sorry for the inconvienence caused

hey ! trying to use your program but i just want to display the sizes. so how can i remove the name of the font style from lngIndex.

Thanks !

Jess

This thread is 5 years old.

Please start a new thread with a reference to this one.