Creating a Document Font List

Although I’ve never had to do this exercise, it seems to me one could save the file as an *.xml. Open and read that with a text editor. Or with a bit of VBA.

Hi
I have used your code very successfully and also cured the speed problem. The limiting item for speed is updating the status bar, so I set it to only display every thousand characters. I also exit the font matching loop when the font is found, to save time. Try these amendments: my scan of a 160 page dense document took ten seconds instead of ten minutes!! Lines 4 and 10.

For Each rngChar In ActiveDocument.Characters
Y = Y + 1
FontName = rngChar.Font.Name
If Y Mod 1000 = 0 Then 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
Exit For
End If
Next J
If Not FoundFont Then
FontCount = FontCount + 1
FontList(FontCount) = FontName
End If
Next rngChar

Another third party solution, but pretty simple. And I don't know why I didn't think of it before.

• Save as htm(l)
• Open the html file in Firefox.
• Hit Ctrl+Shift+i to bring up the Developer tools.
• In the right-hand pane of the Developer tools window, select Fonts.
• Click Show more, if available. You should see something like the picture below.
• Copy the list of fonts into an empty Word document. (Ctrl+A selects more than you need and there's no right-click available, so it's a case of drag-select and Ctrl+C.)
• Run the macro below to get rid of the unneeded lines.
• And you're done.

The Pale Moon browser (a fork of Firefox 20-something) has a similar utility but the list is wordier and includes duplicates. If Chrome or (shudder) I.E. have a fonts list in their dev tools, I can't find it.

Sub firefoxFontList()

Selection.HomeKey unit:=wdStory
Set oRng = ActiveDocument.Range

For i = 1 To oRng.Paragraphs.Count
If i Mod 2 = 0 Then
ActiveDocument.Paragraphs(i).Range.text = vbCr
End If
Next

With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.text = "[^13]{1,}"
.Replacement.text = "^p"
.Forward = True: .Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With

ActiveDocument.Paragraphs.Last.Range.Delete


End Sub

(see Figure 1 below)

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

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.

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.

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.

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

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

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.

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

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

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

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

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.

Daz

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

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.

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.

Ken,

Sorry, I misnamed you!

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.

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.

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)

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.

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

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

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