Hi,
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?
Thanks!
Jason Moore
You might already be aware of this, but I add this here as general information: One can go to File>Document Info, use checkboxes to set what information is shown, and then save that information to a text file. "Text statistics" includes a list of fonts used in the document.
For a macro such as the one you describe, someone has already written some code that creates a font list. For output, that macro produces an Artistic Text object.
See this thread on the Oberon Place forum. The code is from Alex Vakulenko, fixed by Shelby Moore.
For future reference, in case that ever disappears:
Sub ListDocumentFonts() Dim p As Page Dim s As Shape Dim col As New Collection Dim sFontList As String Dim vFont As Variant For Each p In ActiveDocument.Pages For Each s In p.FindShapes(, cdrTextShape) FindFontsInRange s.Text.Frame.Range, col Next s Next p sFontList = "" For Each vFont In col If sFontList <> "" Then sFontList = sFontList & vbCrLf sFontList = sFontList & vFont Next vFont ActiveDocument.Pages(1).ActiveLayer.CreateParagraphText 0, 0, 3, 8, sFontList, Font:="Arial", Size:=10 End Sub 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 Else AddFontToCollection FontName, col End If End Sub 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 Exit For End If Next v If Not bFound Then col.Add FontName End Sub
Thanks eskimo!
I am aware of the File>Document Info and checking the box, but we don't want to add all those steps in order to do that for each file we create.
We are lazy =)
I read the thread in the link you posted and Alex says the following
"Here is a piece of code which will look into each text object, even if the same text object has several different fonts in it and build the list of all fonts used in the document. It then creates a paragraph text object and puts the font list in it. You can change the macro to dump it into a text file or show it in a text box on a dialog, so it can be copied and pasted."
So, how can I change the macro to dump it to a text file as he says? This would be exactly what we need it to do.
We use both X4 and 2017...would this be able to be used in both versions?
Thank you SO much for your help.
Jason
I commented out one line, and added a few lines to write a text file. Someone who knows more about VBA than I do may see this and suggest some improvements.
I haven't done anything to make this fault-tolerant. Run it on a document that has never been saved, for example, and it will throw an error - and I haven't put any error handling in the macro.
I've tried this in X3 and in 2018, and it appears to work. So, a .GMS file, zipped to be acceptable to the forum software:
document_font_list.zip
The code looks like this now:
Sub WriteDocumentFontsToFile() Dim p As Page Dim s As Shape Dim col As New Collection Dim sFontList As String Dim vFont As Variant 'added Dim strTextFileName As String Dim TextFile As Long '---------------------- For Each p In ActiveDocument.Pages For Each s In p.FindShapes(, cdrTextShape) FindFontsInRange s.Text.Frame.Range, col Next s Next p sFontList = "" For Each vFont In col If sFontList <> "" Then sFontList = sFontList & vbCrLf sFontList = sFontList & vFont Next vFont 'ActiveDocument.Pages(1).ActiveLayer.CreateParagraphText 0, 0, 3, 8, sFontList, Font:="Arial", Size:=10 'added TextFile = FreeFile strTextFileName = Left(ActiveDocument.FullFileName, InStrRev(ActiveDocument.FullFileName, ".")) & "txt" Open strTextFileName For Output As TextFile Print #TextFile, sFontList Close TextFile MsgBox "Document font list was written to " & strTextFileName '---------------------- End Sub 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 Else AddFontToCollection FontName, col End If End Sub 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 Exit For End If Next v If Not bFound Then col.Add FontName End Sub
Jason Moore said:
Sorry, but.. . you say you're lazy but you want to use so complicated piece of software, made and corrected by several programmers, for something that's already present on the program since the past century, and you can simply assign a shortcut such as Ctrl+1 for do it?
Hi Eskimo!
This works perfectly!! Thank you SOOOOOO much!!!!
There's only one last thing I was wondering....is it possible to add a line in this code that would let me hard code the directory to save the new TXT file into? We don't want it saved in the same folder as the artwork.
Thank you again SO much!
Hi Ariel,
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.
Jason,
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.
Sub WriteDocumentFontsToFile() Dim p As Page Dim s As Shape Dim col As New Collection Dim sFontList As String Dim vFont As Variant 'added 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 Next s Next p sFontList = "" For Each vFont In col If sFontList <> "" Then sFontList = sFontList & vbCrLf sFontList = sFontList & vFont Next vFont 'ActiveDocument.Pages(1).ActiveLayer.CreateParagraphText 0, 0, 3, 8, sFontList, Font:="Arial", Size:=10 'added TextFile = FreeFile strTextFileName = strFontFilePath & Left(ActiveDocument.FileName, InStrRev(ActiveDocument.FileName, ".")) & "txt" Open strTextFileName For Output As TextFile Print #TextFile, sFontList Close TextFile MsgBox "Document font list was written to " & strTextFileName '---------------------- End Sub 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 Else AddFontToCollection FontName, col End If End Sub 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 Exit For End If Next v If Not bFound Then col.Add FontName End Sub