Someone make an Active List Font macro

Anyone able to draft us up a Macro to list Active fonts in a document.
Maybe call it a font lister or something.....

ex.

Fonts Used:

-> Arial.ttf
-> Goudy Bold
-> Times New Roman

Well ya get the idea
This would be helpful for me that I could have a small list of Active Fonts
that I could set off to the side in my drawings.

Having the font listed is alot easier to activate then browsing thru the font list for a match or going thru the trouble of typing them all in.

This would also help with Extensis Suitcase to enable certain fonts.

Is this doable? It will save many lives.......

Thanx all!

-dung

PS: If it is possible to create this for Vers. 9 - 12 ??

[shelbym]

This might help a little: In CorelDraw 12 go: File| Document Info scroll down to Text Statistics and it lists all the fonts used in the document. I know it is not exactly what you want, but it might help a little.

[shelbym]

This might help also. This code will list all the fonts used in the active document. This code works under CorelDraw 12, have not tested it under other versions.

Sub ProcessAllObjects()
    FindFontNames ActivePage.Shapes, FontCollection
    MsgBox FontCollection
End Sub

Public Sub FindFontNames(ss As Shapes, FontCollection)

Dim s As Shape
For Each s In ss
    If s.Type = cdrGroupShape Then
        FindFontNames s.Shapes, FontCollection
    Else
        If s.Type = cdrTextShape Then
            FontCollection = FontCollection & " " & s.Text.FontProperties.Name & Chr(13)
        End If
    End If
Next s
End Sub

OK, that works

But could I get it to go on the page instead of a message box?
Btw, I seen Text statistics but didnt want that.

I'd like to include the list of fonts used with some job sketches that I will print out

Bump

[Alex]

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.

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

Hey is there any code for x4 which does this?

Ta.

Fungel

[shelbym]

Alex's code above works find in X4, you just have to fix a couple things from when the site was converted. Here is a fixed copy.

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

Best of luck,

-Shelby

[inkmachine]

Hi!

This macro works great, but Shelby mentioned that you can adjust it to save the names of the fonts into a TXT file.

This would be perfect for us.

Is it possible for the file to be saved into a certain directory and named the exact same name as the CDR file except as a TXT file?

For example...the CDR is names 73456.CDR so the font text file would be named 73456.TXT

And the last question about this macro is this....

Could this be made so that it could do this process as a batch file on numerous CDR files at a time...maybe like 50 to 100 files in a batch if possible?

I guess it would basically open the CDR file, scan for fonts, send the font names into a text file, close the CDR file and then open the next CDR file etc....

Is that possible?

Thanks so much!!!