Please Note: This article is written for users of the following Microsoft Word versions: 2007, 2010, and 2013. If you are using an earlier version (Word 2003 or earlier), this tip may not work for you. For a version of this tip written specifically for earlier versions of Word, click here: Creating a Document Font List.

Creating a Document Font List

by Allen Wyatt
(last updated October 4, 2019)

23

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 ListFontsInDoc()
    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 5 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.

Note:

If you would like to know how to use the macros described on this page (or on any other page on the WordTips sites), I've prepared a special page that includes helpful information. Click here to open that special page in a new browser tab.

WordTips is your source for cost-effective Microsoft Word training. (Microsoft Word is the most popular word processing software in the world.) This tip (13313) applies to Microsoft Word 2007, 2010, and 2013. You can find a version of this tip for the older menu interface of Word here: Creating a Document Font List.

Author Bio

Allen Wyatt

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. ...

MORE FROM ALLEN

Setting Grammar-Checking Options

When Word checks the grammar it thinks you are using in your prose, it follows a set of rules. Fortunately, the program ...

Discover More

Changing Section Headers

Add subtotals to a worksheet and you can instruct Excel to start each new subtotal section on a new printed page. You may ...

Discover More

Protecting a Single Worksheet

Excel allows you to protect your worksheets easily—and that includes if you need to protect only a single worksheet ...

Discover More

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 need them! Check out Microsoft Word 2013 Step by Step today!

More WordTips (ribbon)

Determining a Random Value

If you need to determine a random value in a macro, you can do so using the Rnd function. This tip presents the syntax ...

Discover More

Deriving an Absolute Value

Want to know the absolute value of a number? It's easy to derive in VBA by using the Abs function.

Discover More

Determining if Caps Lock is On

If your macro needs to determine the status of the Caps Lock key, you need the code in this tip. Just use the Information ...

Discover More
Subscribe

FREE SERVICE: Get tips like this every week in WordTips, a free productivity newsletter. Enter your address and click "Subscribe."

View most recent newsletter.

Comments

If you would like to add an image to your comment (not an avatar, but an image to help in making the point of your comment), include the characters [{fig}] (all 7 characters, in the sequence shown) in your comment text. You’ll be prompted to upload your image when you submit the comment. Maximum image size is 6Mpixels. Images larger than 600px wide or 1000px tall will be reduced. Up to three images may be included in a comment. All images are subject to review. Commenting privileges may be curtailed if inappropriate images are posted.

What is seven more than 4?

2021-11-29 10:53:23

Daz

On a completely different tack; something interesting a friend just pointed out to me when I told her about this. If a paragraph contains only one font, you can get VBA to report the font name. If it doesn't, you can't.

So, we could speed up the character-by-character process by making it paragraph-by paragraph instead, with something like:
If ActiveDocument.Paragraphs(i).Range.Font.name = "" Then
'DO CHAR-BY-CHAR THROUGH PARAGRAPH(i)
End If

The only place it fails is that it (sometimes, which is weird) doesn't report "" if white-space within the paragraph has a different font from the text. Which I'd assume isn't likely to happen too often, and which likely wouldn't bother most people anyway. If even one non-white-space character is in a different font from the rest, it'll report "".


2021-11-29 07:43:58

Daz

Ken,

So far I've not had the problem with files saved as filtered html "holding on" as it were to Word-specific labelling such as body or headings. Looking at the htm file's souce code, headings, for instance are styled in the usual css fashion, with a font-family specified in the style section of the header, and no extra tagging within the <h#> html tag. Re-opening the file for editing in Word, both ctrl F/H and VBA appear, under all the circumstances I've tried so far, to treat that as plain old Cambria, the same as any non-heading text that's been changed to that font, rather than as the Word-specific "Cambria (Headings)."

That all appears to be true provided the file has been closed after saving to filtered.htm and then re-opened. (Caveat: I've still not tried it with a second document open, so that Word itself wouldn't be closed and re-opened at the same time as the document. I Can't see how, but it's possible that closing the entire program also purges any Word-specific tagging it may have cached for, but not written to, the .htm file.)

The one that worries me is "default." Despite trying my best I've not yet managed to make things go Horribly Wrong in that aspect, using this method, but it bothers me that there _is_ a vestige of it kept in the filtered html source-code. Specifically, the default font (Code2000 in my case) is rendered twice in the font-definitions:

@font-face
{font-family:Code2000;
panose-1:2 0 6 0 0 0 0 0 0 0;}
@font-face
{font-family:"\@Code2000";
panose-1:2 0 6 0 0 0 0 0 0 0;}

It only ever appears in the style section as plain old "font-family:Code2000;" but it bothers me nonetheless that unlike with the headings and body fonts, when Word parses the htm file, there is still a way for it to see that this particular font might need to be treated differently under some circumstance I've yet to find. It would be easy enough to remove the second, "\@", version from the html source code in a text-editor before re-opening in Word, but that doesn't strike me as advice I'd want to pass on to a user whose tech-savviness I was unsure of.


2021-11-29 05:42:33

Ken Endacott

Daz,

Your Find & Replace approach is the most promising but there are a couple of issues.

Office F&R which you get in Word by pressing CTRL + H interacts with VBA Find, I understand that they are also related to Windows Find, probably use a common search engine. The result is a mess with all sorts of problems – I could give examples that defy logic and also code that should work but crashes Word.

Fonts can have the suffix (Body) and (Headings), for example “Calibri (Headings)” To find these fonts it is necessary to search for +Body and +Headings.

It is a different matter with the prefix (Default) A document can have some text with the font “Times New Roman” and some with the font “(Default) Times New Roman”, VBA Find can be used to find the former but not the latter unless one does a dance with F&R and VBA Find. I have yet to determine a work around, until then the F&R approach is not practical.


2021-11-28 11:03:01

Daz

Okay, so, so far, this seems to work. Having dashed my hopes against this particular rock a fair few times now, I'm not going to say it _definitively_ works until I've tried every way I can to break it, but…

Save the document as _filtered_ htm(l).

Close the document, right-click the newly created [whatever].htm file, and click Edit, to re-open it in Word. (This appears to turn all the font-face definitions into hard-coded fonts, regardless of whether they were originally applied using Styles or not. Weirdly, it does seem to make a difference whether the file has been manually re-opened. Or, come to think of it, possibly it's because Word itself was closed and re-opened when I tried it?)

My original idea of repeated search-and-replace using the font-name of the first character in the document now appears to work. Certainly I've had no problems so far with body text or headings. I've (touch wood) so far not been able to replicate the default-font problem that I ran into when saving as .doc, either—which (if it turns out to be definitively true) would make sense, since a default font has always been a feature of Word, even in the pre-styles versions, but it's never been a valid html or css entity.


2021-11-12 15:12:37

Daz

*Sigh*

Please disregard all my comments regarding using html files. The method completely breaks down when Styles are added. Libre Office Writer makes much nicer html, without spurious additions in the CSS of fonts which aren't actually used. And it doesn't, as Word does, wrap a heading element that displays as Cambria in a completely different font-face span. Which is more than weird; it's perverse. So yeah, we _could_ utilise that (generate a look-up table to get an element's font from its html class)—but if we're using third party software, the Calibre workaround I mentioned is quicker, for very large documents at least, and we don't have to install a whole nother office suite.


2021-11-10 22:22:27

Daz

Well, I've not yet instituted a counter (I've got a few ideas, but I want something vaguely graceful), but I'm regarding this as userFriendlyVersion 1.0.

The comments pretty much summon it up. It deals with saving (or at least prompting to save) documents with unsaved changes, including never-saved new documents, and it re-opens the original docx file or, if the user chooses not to save a never-saved doc, it opens a new blank document—which feels somewhat more user-friendly than the greyed out blank window you're otherwise left with. New, never-saved files are saved, if the user chooses to save them, to the desktop as Document(number).docx And it deletes the htm/text file and the associated files-folder.

Comes with a bunch of functions and a separate sub, most of which are useful for other jobs (which is why I had them kicking around in the first place).

With my War And Peace document (1,146 pages, 10 fonts) it takes 15 to 20 seconds, depending mostly on how absurdly many browser tabs I happen to have open. Oh, and I'm working with Office 2010, if that makes any difference.

Sub getFontsInDocMethod3()

Set doc = ActiveDocument
Dim strPath As String: strPath = getFullPath
Dim tmpPath As String, s As String
Dim saveCheck As Boolean

'===============================
'Prompt to save, if needed.
If doc.Saved = False _
Or Not doc.FullName Like "*.*" Then
Dim t As String

If Not doc.FullName Like "*.*" Then
t = "This document has not been saved."
Else
t = "There are unsaved changes."
End If

Dim iResponse As Integer
iResponse = MsgBox(t & vbCr _
& "All changes will be lost." _
& vbCr & "Do you want to save" _
& " the document before continuing?", _
vbYesNoCancel)

If iResponse = vbYes Then _
doc.SaveAs2 fileName:=strPath

If iResponse = vbNo _
And Not doc.FullName Like "*.*" Then _
saveCheck = True

If iResponse = vbCancel Then Exit Sub
End If
'===============================
'Export to htm(l) and turn the
' resulting file into .txt so
' that Word can read the source code.
tmpPath = makeUniqueFolder("C:\myTmp")

doc.SaveAs2 fileName:=tmpPath & "tmp.htm", _
FileFormat:=wdFormatHTML
Documents(tmpPath & "tmp.htm").Close SaveChanges:=0
If saveCheck = False Then
Documents.Open strPath
Else
Documents.Add
End If
Name tmpPath & "tmp.htm" As tmpPath & "tmp.txt"
'=============================
'This part is the (corrcted version
' of) the one I posted before.
'Filter the source code for font
' spans, then isolate the font-names
' and report them.
Dim sFile As String, sWhole As String
Dim v As Variant, x As Variant

sFile = tmpPath & "tmp.txt"
Open sFile For Input As #1
sWhole = Input$(LOF(1), 1)
Close #1
sWhole = Replace(sWhole, vbNewLine, "")
sWhole = Replace(sWhole, vbCr, "")
v = Split(sWhole, "<")

For i = 0 To UBound(v)
If v(i) Like "span*font-family*>*" Then
Do While Not v(i) Like "*>*"
v(i) = Left(v(i), Len(v(i)) - 1)
Loop
Do While Not v(i) Like "family*"
v(i) = Right(v(i), Len(v(i)) - 1)
Loop
Do While Not v(i) Like ":*"
v(i) = Right(v(i), Len(v(i)) - 1)
Loop
v(i) = Right(v(i), Len(v(i)) - 1)
Do While v(i) Like "*,*" _
Or v(i) Like "*;*"
v(i) = Left(v(i), Len(v(i)) - 1)
Loop
v(i) = Replace(v(i), """", "")
x = x & "|" & v(i)
End If
Next

v = Split(x, "|")
v = RemoveDupesColl(v)

For i = 1 To UBound(v)
s = s & v(i) & vbCr
Next
MsgBox "" _
& UBound(v) & " fonts were found:" _
& vbCr & vbCr & s
'=============================
'Clean up temporary html files and folders.
removeDirectoryContents (tmpPath)
RmDir tmpPath

End Sub

Function getFullPath()

'Returns full\path\fileName.extension
'of the active document including
' creating one on the user's desktop
' for never-saved documents.
Dim docName As String: docName = ActiveDocument.name
Dim docPath As String: docPath = ActiveDocument.path

If docPath = "" Then
docPath = Environ$("USERPROFILE") & "\Desktop"
docName = ActiveDocument.name & ".docx"
End If

getFullPath = docPath & "\" & docName

End Function

Function makeUniqueFolder(x) As String

'Checks to see if a directory
' exists and, if so, adds
' a number to the name and,
' creates the folder and
' returns the new, unique, name.
Dim strFolderName As String
strFolderName = x
If x Like "*\" Then
x = Left(x, Len(x) - 1)
End If
Dim i As Integer: i = 0
Dim b As String: b = strFolderName & "\"

Do While CheckFolderExists(b) = True
i = i + 1
b = strFolderName & str(i) & "\"
Loop
strFolderName = b
MkDir b
makeUniqueFolder = b
End Function

Function CheckFolderExists(s)

Dim strFolderName As String
Dim strFolderExists As String

strFolderName = s
strFolderExists = dir(strFolderName, vbDirectory)

If strFolderExists <> "" Then
CheckFolderExists = True
End If
End Function

Sub removeDirectoryContents(s As String)

Dim sPath As String: sPath = s
Dim o As FileSystemObject

If Right(sPath, 1) = "\" Then
sPath = Left(sPath, Len(sPath) - 1)
End If

Set o = CreateObject("Scripting.FileSystemObject")

If o.folderExists(sPath) Then
o.DeleteFile sPath & "\*.*", True
o.DeleteFolder sPath & "\*.*", True
End If
End Sub

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from
' your array using the collection method.
'NOTES: (1) This function returns unique
' elements in your array, but
' it converts your array elements to strings.
'SOURCE: h t t p s: / /wellsr.com
'-----------------------------------------------------------------------
Dim i As Long
Dim arrColl As New Collection
Dim arrDummy() As Variant
Dim arrDummy1() As Variant
Dim item As Variant
ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

For i = LBound(MyArray) To UBound(MyArray) 'convert to string
arrDummy1(i) = CStr(MyArray(i))
Next i
On Error Resume Next
For Each item In arrDummy1
arrColl.Add item, item
Next item
Err.Clear
ReDim arrDummy(LBound(MyArray) _
To arrColl.Count + LBound(MyArray) - 1)
i = LBound(MyArray)
For Each item In arrColl
arrDummy(i) = item
i = i + 1
Next item
RemoveDupesColl = arrDummy
End Function


2021-11-10 15:09:35

Daz

Ken,

I like it in principle, but I'm getting the error message on about one in four tries, with different documents. I'm pretty sure it's a collision between hard-coded formatting and styled, which is more like your proper CSS. From a strict (x)html point of view, Word's output is a horrible monster of a thing.

Makes me wonder though. If I can similarly automate the htm(l) method, without resorting to mucking about with text-editors, the result would be functionally the same user-experience as the find-replace method. Except I can't think of a way to get the character count for each font, which is a pity. It would be a _lot_ faster though because it's all done by manipulating virtual strings. Working with an already-created text file of my War And Peace source-code, we're talking of a handful of seconds; it's the Save as… etc which takes most of the time. Saying that, I could easily get a count of the number of _occurrences_ of each font, with the caveat that each paragraph counts as a separate occurrence—so a five-paragraph document with one font used throughout would report as five occurrences.


2021-11-10 00:33:52

Ken Endacott

Daz,

Here is my version that creates a temporary .doc file, determines the fonts in use and deletes the temporary file. It is remarkably quick, taking 3 seconds to process a 300,000 character, 240 page document with 7 fonts. The number of characters with each font is displayed. It only checks fonts in the document body but could be extended to also check in other stories.

Sub getFontsInDocMethod2()
Dim s As String, sFontName As String, i As Integer
Dim kStart As Long
Dim k As Long
Dim tst As Boolean
Selection.HomeKey unit:=wdStory
ActiveDocument.GoTo What:=-1, Name:="\StartOfDoc"
ActiveDocument.SaveAs2 FileName:="Test doc.doc", CompatibilityMode:=wdWord2003
Application.ScreenUpdating = False

kStart = ActiveDocument.Characters.Count
s = ""
i = 0
Do Until ActiveDocument.Range.Text = ChrW(13)
sFontName = ActiveDocument.Range.Characters.First.Font.Name
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = ""
.Format = True
.Text = ""
.Font.Name = sFontName
tst = .Execute(Replace:=wdReplaceAll)
End With
k = ActiveDocument.Characters.Count

If k = kStart Then
MsgBox "Error. Results incomplete"
Exit Do
End If
s = s & sFontName & Str(kStart - k) & vbCr
i = i + 1
kStart = k
Loop

Documents("Test doc.doc").Close SaveChanges:=0
Kill ("Test doc.doc")

Application.ScreenUpdating = True
MsgBox i & vbCr & s, , "Fonts in use"
End Sub


2021-11-08 23:45:47

Daz

…and the first line in the For loop should read:
If v(i) Like "span*font-family*>*" Then

Not sure how or when I deleted that very important asterisk.


2021-11-08 22:44:22

Daz

Re: my previous,
The "j as Long" dim is unneeded. It's a remnant of an earlier iteration wherein I needed a counter.


2021-11-08 22:36:36

Daz

Okay, it's a bit round-about but it's pretty darned quick. (Tested on War And Peace, pasted unformatted and then with a load of random font-changes made. Thank you, Project Gutenberg!)

Step one: save your document as an _unfiltered_ web page.

Step two: open the resulting htm(l) file in a text editor. Search for the <body…> tag, and delete that and everything above it. (Surprisingly, Notepad++ balked at this a couple of times, while the normally not quite so nifty TED Notepad made quick work of it.)

Step three: save the file as whatever.txt.

Step four: open a blank Word document and run the macro below.

Total time, about a minute, including all the preliminary steps.

I've hard-coded the path to the text file. Probably using a file-picker would be a better idea.

The RemoveDupesColl function isn't my work. I've left the writer's comment in place, including a link (spaced out to avoid creating an actual clicky-link) to the source. And, frankly, I'm still trying to grok how it does what it does.


Sub getFontsInDoc_ByTheLordHarryIThinkIDidIt()

Dim sFile As String, sWhole As String
Dim v As Variant, x As Variant, j As Long

sFile = "C:\path\to\text\file.txt"
Open sFile For Input As #1
sWhole = Input$(LOF(1), 1)
Close #1
sWhole = Replace(sWhole, vbNewLine, "")
sWhole = Replace(sWhole, vbCr, "")
v = Split(sWhole, "<")

For i = 0 To UBound(v)
If v(i) Like "span*font-family*>" Then
Do While Not v(i) Like "*>"
v(i) = Left(v(i), Len(v(i)) - 1)
Loop
Do While Not v(i) Like "family*"
v(i) = Right(v(i), Len(v(i)) - 1)
Loop
Do While Not v(i) Like ":*"
v(i) = Right(v(i), Len(v(i)) - 1)
Loop
v(i) = Right(v(i), Len(v(i)) - 1)
Do While v(i) Like "*,*" _
Or v(i) Like "*;*"
v(i) = Left(v(i), Len(v(i)) - 1)
Loop
v(i) = Replace(v(i), """", "")
x = x & "|" & v(i)
End If
Next

v = Split(x, "|")
v = RemoveDupesColl(v)

For i = 1 To UBound(v)
Selection.TypeText v(i) & vbCr
Next
ActiveDocument.Range.InsertBefore "" _
& UBound(v) & " fonts were found:" & vbCr & vbCr
Selection.HomeKey unit:=wdStory

End Sub

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from
' your array using the collection method.
'NOTES: (1) This function returns unique
' elements in your array, but
' it converts your array elements to strings.
'SOURCE: h t t p s: / /wellsr.com
'-----------------------------------------------------------------------
Dim i As Long
Dim arrColl As New Collection
Dim arrDummy() As Variant
Dim arrDummy1() As Variant
Dim item As Variant
ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

For i = LBound(MyArray) To UBound(MyArray) 'convert to string
arrDummy1(i) = CStr(MyArray(i))
Next i
On Error Resume Next
For Each item In arrDummy1
arrColl.Add item, item
Next item
Err.Clear
ReDim arrDummy(LBound(MyArray) _
To arrColl.Count + LBound(MyArray) - 1)
i = LBound(MyArray)
For Each item In arrColl
arrDummy(i) = item
i = i + 1
Next item
RemoveDupesColl = arrDummy
End Function


2021-11-08 12:33:40

Daz

Ken,

I did that and all of a sudden managed to replicate the Default problem. So i saved it as filtered html and it worked a charm. Very strange. We're on to something here, but I have no idea what.


2021-11-08 09:45:25

Ken

Daz

Saving the document as .doc seems to remove the supplement from the font names.


2021-11-08 07:22:30

Daz

Ken,

I played with that yesterday after tearing my hair out over the body-headings-default thing. Problem is, the very fonts that we're left with after removing the ones we _can_ find, are very likely to be by far the most abundant in the document. So we don't gain much.

An interesting workaround: if you have the Calibre ebook organiser installed, import the docx file into that, and convert to epub, making sure to check the "Embed all fonts in document" option in the "Look and feel" section of the conversion dialogue. (The conversion took about eight minutes for "War And Peace" on my admittedly somewhat antiquated machine.) When it's done, right click the book in Calibre's listing and select "Edit book." You'll find all the fonts used listed in the page_styles.css.


2021-11-08 05:22:40

Ken

Daz,

I wonder if a hybrid method using your idea plus a character-by-character test would work. When the macro came to a character that has a font name that Find could not see then step character by character until a regular font name is found.


2021-11-07 08:23:46

Daz

Ken,

Sorry, I misnamed you!


2021-11-07 08:20:40

Daz

Kev,

Well that's a blow. Seems I've been lucky that it's not happened to me. (And after a spot of googling I've just replicated the problem by changing a chunk of text to Calibri.) Thanks for the info.

Regarding the endless loop, there's a caveat built into the loop that won't allow it to continue after the counter gets higher than the available number of fonts, so there's that. But ho-hum, back to the drawing board.

Having some luck with searching with the term: '.Font.NameAscii = ("+Body")' before the Do Until loop, but I can't get it to work with '("+Headings")' for some reason and as yet I've not managed to replicate the 'Default' scenario.

If none of that works, well years ago I used to have a macro that crawled through the body section of a document saved as non-filtered html, counting font tags—but my slight knowledge of VBA at that time turned it into an ugly, spaghettified monster . I can see if I can replicate that with a bit more grace; it still ought to be faster than going character-by-character on large documents.


2021-11-05 01:45:18

Ken

Daz,

It is a neat idea to use VBA Find which should be much faster than the character-by-character approach. However, there are quirks that cause trouble. Word creates extensions to font names such as “Calibri (Body)” and “(Default) Times New Roman” and you cannot search for those. Thus a document can contain some text with “Calibri” and some with “Calibri (Body)” font. VBA Find will find the former but not the latter. The result is that your macro fails to find the font of the first character, gets into an endless loop and crashes Word. Your code could check the result of the Find.Execute and if false then stop execution but then only part of the document is tested.


2021-11-03 16:24:16

Daz

This works for me. I'd strongly advise working on a copy of the document just in case, though, since it works by removing huge chunks of content until the document's empty.

Sub getFontsInDoc()

Application.ScreenUpdating = False

'Make an undo point
Application.UndoRecord.StartCustomRecord ("Get Fonts")

Selection.HomeKey unit:=wdStory
Dim s As String, sFontName As String, i As Integer
i = 0

' Find out the font of the first character in
' the document & and remove all instances of
' that font, until the document is empty. With
' a get-out if the count exceeds the number of
' available fonts—in which case, something's
' gone horribly wrong!
Do Until ActiveDocument.Range.text = ChrW(13) _
Or i > FontNames.Count
sFontName = ActiveDocument _
.Range.Characters.first.Font.name

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.text = "": .Font.name = sFontName
.Replacement.text = "": .Format = True
End With
Selection.Find.Execute Replace:=wdReplaceAll

s = s & sFontName & vbCr
i = i + 1
Loop

'Finish the undo point and undo
'all the removals we just made.
Application.UndoRecord.EndCustomRecord
ActiveDocument.Undo 1

Application.ScreenUpdating = True

MsgBox i & vbCr & s

End Sub

(see Figure 1 below)

Figure 1. 


2020-12-08 10:25:11

Andrew Burrell

Very useful, thank you.
However, the code was not able to identify the font used in headers and footers.
Can you add code to be able to do that? Granted, this is not too difficult to do manually, so only a thought.


2016-12-24 05:18:33

Ken Endacott

The list should include the font sizes
Also the StatusBar should be updated less frequently.

Replace the following statements:

FontName = rngChar.Font.Name
StatusBar = Y & ":" & X

with:

FontName = rngChar.Font.Name & " " & Str(rngChar.Font.Size)
If Y Mod 1000 = 0 Then StatusBar = Y & ":" & X


2015-12-11 00:31:48

V.S.Rawat

It would have been more convenient, if, instead of opening a new file, the code would have shown the found font as a ListBox window.

That way, others could have directly used the code for conversion of FontList to a List box and then displaying it.

Currently, opening a new file showing fonts name has no real life application.

Of course, it does explains and shows the method.

Thanks.
--
Rawat


2015-12-11 00:27:30

V.S.Rawat

The tip was very useful for understanding this area of vba.

some suggestions.

1. vba has 0 as default lbound for arrays, but the code above starts filling the array at 1, which leaves a hole at index 0. Changing the code as below will remove this hole.

For J = 1 To FontCount
If FontList(J - 1) = FontName Then FoundFont = True
Next J
If Not FoundFont Then
FontList(FontCount) = FontName
FontCount = FontCount + 1
End If
Next rngChar
--

2. Instead of a for loop, you can use a single line command to display the array.
MsgBox Join(FontList, vbCr)

3. Instead of one by one sorting, you can use the single line command to do the sorting.
WordBasic.SortArray FontList, 0, 0, FontCount - 1, 0, 1

Hope you don't mind my sharing this.

Thanks.
--
Rawat
India



This Site

Got a version of Word that uses the ribbon interface (Word 2007 or later)? This site is for you! If you use an earlier version of Word, visit our WordTips site focusing on the menu interface.

Newest Tips
Subscribe

FREE SERVICE: Get tips like this every week in WordTips, a free productivity newsletter. Enter your address and click "Subscribe."

(Your e-mail address is not shared with anyone, ever.)

View the most recent newsletter.