Is there a way that one can determine which fonts are used in any particular document?
April 9, 2024
Contribute to the Microsoft 365 and Office forum!
Click here to learn more 💡
May 10, 2024
Word Forum Top Contributors:
List fonts used in a particular document
Report abuse
Thank you.
Reported content has been submitted
John,
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
Do
'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
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
End If
If oCol.Item(arrIndexPasssed(lngIndex)) >= oCol.Item(arrIndexPasssed(i)) Then
Exit Do
End If
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
***
Death smiles at us all, but all a man can do is smile back.
For more help with Word visit:
http://gregmaxey.com/word_tips.html
Report abuse
Thank you.
Reported content has been submitted
17 people found this reply helpful
·Was this reply helpful?
Sorry this didn't help.
Great! Thanks for your feedback.
How satisfied are you with this reply?
Thanks for your feedback, it helps us improve the site.
How satisfied are you with this reply?
Thanks for your feedback.
In a web search, I found a macro from a source I've used before here:
http://word.tips.net/T001522_Creating_a_Document_Font_List.html
And a possibly faster method here, which might be worth looking into (the code is way beyond my vba-reading skills):
http://stackoverflow.com/questions/5261108/list-fonts-used-by-a-word-document-faster-method
Good luck,
Pam
Report abuse
Thank you.
Reported content has been submitted
5 people found this reply helpful
·Was this reply helpful?
Sorry this didn't help.
Great! Thanks for your feedback.
How satisfied are you with this reply?
Thanks for your feedback, it helps us improve the site.
How satisfied are you with this reply?
Thanks for your feedback.
Question Info
Last updated April 20, 2024 Views 52,138 Applies to: