Is there a macro out there that when activated, will do the following?
1.) Create a new TXT file.
2.) List the name of all fonts used in the document
3.) Save the TXT file using the same name as what the current document is named to a specified directory.
4.) Close the TXT file.
Is there an existing macro that can do this or would this be a difficult thing to accomplish?
I'm sorry, but the built in function doesn't work the way that we needed it to. It doesn't automatically generate the file name of the TXT file based on the current files name.
I didn't mean to offend you.
Eskimo helped out tremendously and made the macro work perfectly for us!
His skills are highly respected and appreciated by us.
This has been tweaked to use a fixed directory location. You can just change the line:
Const strFontFilePath As String = "D:\font lists from macro\" to be what you want.
Again, I haven't taken the time to make this fault-tolerant, so it's not checking to see if the directory exists.
After you're sure that functionality of the macro is what you want, we could add a couple of checks to avoid common ways that it could fail.
Dim p As Page
Dim s As Shape
Dim col As New Collection
Dim sFontList As String
Dim vFont As Variant
Dim strTextFileName As String
Dim TextFile As Long
Const strFontFilePath As String = "D:\font lists from macro\"
For Each p In ActiveDocument.Pages
For Each s In p.FindShapes(, cdrTextShape)
FindFontsInRange s.Text.Frame.Range, col
sFontList = ""
For Each vFont In col
If sFontList <> "" Then sFontList = sFontList & vbCrLf
sFontList = sFontList & vFont
'ActiveDocument.Pages(1).ActiveLayer.CreateParagraphText 0, 0, 3, 8, sFontList, Font:="Arial", Size:=10
TextFile = FreeFile
strTextFileName = strFontFilePath & Left(ActiveDocument.FileName, InStrRev(ActiveDocument.FileName, ".")) & "txt"
Open strTextFileName For Output As TextFile
Print #TextFile, sFontList
MsgBox "Document font list was written to " & strTextFileName
Private Sub FindFontsInRange(ByVal tr As TextRange, ByVal col As Collection)
Dim FontName As String
Dim trBefore As TextRange, trAfter As TextRange
FontName = tr.Font
If FontName = "" Then
' There are more than one font in the range
' Divide the range in two and look into each half separately
' to see if any of them has the same font. Repeat recursively
Set trBefore = tr.Duplicate
trBefore.End = (trBefore.Start + trBefore.End) \ 2
Set trAfter = tr.Duplicate
trAfter.Start = trBefore.End
FindFontsInRange trBefore, col
FindFontsInRange trAfter, col
AddFontToCollection FontName, col
Private Sub AddFontToCollection(ByVal FontName As String, ByVal col As Collection)
Dim v As Variant
Dim bFound As Boolean
bFound = False
For Each v In col
If v = FontName Then
bFound = True
If Not bFound Then col.Add FontName
I just ran the macro this time and it brought up an error.
The previous version ran fine without an error.
Btw, I am running this using X4 and 2017.
Sorry, I goofed and only pasted one subroutine. I've gone back to my most recent post and changed it.
Here's a GMS file to save the cut-and-paste, if you wish:
document_font_list 2018-04-23 1045.zip
Thank you so much Eskimo!!
We really really appreciate your help!