OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 11-10-2004, 17:16
dungbtl
Guest
 
Posts: n/a
Default 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 ??
Reply With Quote
  #2  
Old 11-10-2004, 18:21
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default

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.
Reply With Quote
  #3  
Old 11-10-2004, 18:32
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default

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.

Code:
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
Reply With Quote
  #4  
Old 12-10-2004, 05:40
dungbtl
Guest
 
Posts: n/a
Default

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
Reply With Quote
  #5  
Old 13-10-2004, 09:46
dungbtl
Guest
 
Posts: n/a
Default

Bump
Reply With Quote
  #6  
Old 13-10-2004, 11:05
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

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.

Code:
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
Reply With Quote
  #7  
Old 06-06-2009, 08:30
fungel
Guest
 
Posts: n/a
Default code for x4?

Hey is there any code for x4 which does this?

Ta.

Fungel
Reply With Quote
  #8  
Old 06-06-2009, 10:30
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,769
Blog Entries: 9
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default List Fonts

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.
Code:
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
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Font list combobox ddonnahoe CorelDRAW/Corel DESIGNER VBA 2 17-02-2005 21:02
How can I make a macro time out? Rick Randall CorelDRAW/Corel DESIGNER VBA 6 09-02-2005 11:16
sorted font list in VBA? lasergraver CorelDRAW/Corel DESIGNER VBA 2 11-05-2004 05:52
An Idea for a handy and easy to make macro vallentin Macros/Add-ons 2 16-03-2004 11:35
New macro to clip curves w.r.t. a border Gerard Hermans Macros/Add-ons 0 09-06-2003 07:50


All times are GMT -5. The time now is 21:58.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com