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

[shaukat74]

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

[gmaxey]

Something like this:


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

[shaukat74]

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.

[gmaxey]

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.


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

[shaukat74]

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

[jess2324]

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

[SamT]

This thread is 5 years old.

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