Results 1 to 9 of 9
  1. #1
    2 Star Lounger
    Join Date
    Mar 2001
    Posts
    114
    Thanks
    0
    Thanked 0 Times in 0 Posts

    print font macro

    I've lost my print font macro. I couldn't find the topic by searching this forum. I seem to remember there was something on the program CD that you could load in to do this, but can't remember that, either.

    Where can I get a macro to print out all my fonts with text examples of each font.

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,853
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: print font macro

    Try this one
    <pre>Sub PrintFontList()
    Dim iCharNumber As Integer, iPointSize As Integer
    Dim iNumberOfFonts As Integer, i As Integer
    Dim vFontName As Variant
    On Error GoTo UserClickedCancel
    iPointSize = InputBox("Which point size do you want the fonts displayed?", _
    "Font List")
    On Error GoTo 0
    Documents.Add
    For Each vFontName In FontNames
    Selection.Font.Size = 10
    Selection.Font.NAME = "Arial"
    Selection.TypeText vFontName & " at " & iPointSize & " points"
    Selection.TypeParagraph
    Selection.Font.Size = iPointSize
    Selection.Font.NAME = vFontName
    For iCharNumber = 33 To 255
    Selection.TypeText Chr(iCharNumber)
    Next iCharNumber
    Selection.TypeParagraph
    Selection.TypeParagraph
    Next vFontName

    UserClickedCancel:

    End Sub</pre>

    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    Uranium Lounger
    Join Date
    Dec 2000
    Location
    Los Angeles Area, California, USA
    Posts
    7,453
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: print font macro

    Gary Frieder created a bunch of macros. Try 'em.

    Macro: PrintStylesList
    by Gary Frieder
    A basic macro to do this:

    Sub PrintStylesList()
    Dim strStyList As String
    Dim objSty As Style
    For Each objSty In ActiveDocument.Styles
    strStyList = strStyList & vbCr & objSty
    Next objSty
    Documents.Add
    Selection.TypeText strStyList
    End Sub

    If you want to narrow the list down to only those in use, you can use this:

    Sub PrintStylesInUseList()
    Dim strStyList As String
    Dim objSty As Style
    For Each objSty In ActiveDocument.Styles
    If objSty.InUse Then
    strStyList = strStyList & vbCr & objSty
    End If
    Next objSty
    Documents.Add
    Selection.TypeText strStyList
    End Sub

    And for those in use in the document:

    Sub PrintStylesInUseInDocList ()
    Dim strStyList As String
    Dim objDoc As Document
    Dim objSty As Style
    Set objDoc = ActiveDocument
    For Each objSty In objDoc.Styles
    If objSty.InUse Then
    With objDoc.Content.Find
    .ClearFormatting
    .Text = ""
    .Style = objSty
    .Execute Format:=True
    If .Found Then
    strStyList = strStyList & vbCr & objSty
    End If
    End With
    End If
    Next objSty
    Documents.Add
    Selection.TypeText strStyList
    End Sub

    this one should print a list of the styles, each one in its own style.


    Sub PrintStylesInUseInDocList_AndApplyEachStyle()
    Dim strStyList As String
    Dim strStyName As String
    Dim objDoc As Document
    Dim objPara As Paragraph
    Dim objSty As Style
    Set objDoc = ActiveDocument
    For Each objSty In objDoc.Styles
    If objSty.InUse Then
    With objDoc.Content.Find
    .ClearFormatting
    .Text = ""
    .Style = objSty
    .Execute Format:=True
    If .Found Then
    strStyList = strStyList & vbCr & objSty
    End If
    End With
    End If
    Next objSty
    objDoc.Save
    objDoc.SaveAs FileName:="StyleList"
    Set objDoc = ActiveDocument
    objDoc.Content.Delete
    Selection.TypeText strStyList
    For Each objPara In objDoc.Paragraphs
    strStyName = objPara.Range.Text
    On Error Resume Next
    objPara.Style = strStyName
    Next objPara
    End Sub

    Hope this helps.

  4. #4
    Super Moderator
    Join Date
    Dec 2000
    Location
    New York, NY
    Posts
    2,970
    Thanks
    3
    Thanked 29 Times in 27 Posts

    Re: print font macro

    Hi Phil,

    These are certainly nice[img]/w3timages/icons/grin.gif[/img], but are for printing lists of styles, not lists of fonts.[img]/w3timages/icons/blush.gif[/img]

  5. #5
    2 Star Lounger
    Join Date
    Mar 2001
    Posts
    114
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: print font macro

    This does what I need, but is there a way to get the fonts to print out in alphabetical order?

  6. #6
    Uranium Lounger
    Join Date
    Dec 2000
    Location
    Los Angeles Area, California, USA
    Posts
    7,453
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: print font macro

    [img]/w3timages/icons/blush.gif[/img][img]/w3timages/icons/blush.gif[/img]Oops. Thanks for catching that.[img]/w3timages/icons/blush.gif[/img][img]/w3timages/icons/blush.gif[/img][img]/w3timages/icons/blush.gif[/img]

  7. #7
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,853
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: print font macro

    Sheesh, you don't want much do you. Isn't the obscure (lack of) order that the macro does good enough for you.

    Well just to show my vindictive side, here is another version that sorts it for you but you can't chose a font size. No reason - just mean.
    <pre>Sub temp1()
    Dim iCharNumber As Integer
    Dim iNumberOfFonts As Integer, i As Integer
    Dim vFontName As Variant

    Documents.Add
    ActiveDocument.Tables.Add Range:=Selection.Range, _
    NumRows:=1, NumColumns:=2
    Application.ScreenUpdating = False

    For Each vFontName In FontNames
    Selection.Font.NAME = "Arial"
    Selection.TypeText vFontName
    Selection.MoveRight Unit:=wdCell
    Selection.Font.NAME = vFontName
    For iCharNumber = 33 To 255
    Selection.TypeText Chr(iCharNumber)
    Next iCharNumber
    Selection.MoveRight Unit:=wdCell
    Next vFontName

    With ActiveDocument.Tables(1)
    .Rows(.Rows.count).Delete 'remove the last empty row
    .Sort SortOrder:=wdSortOrderAscending ' sort on the first column
    .Columns.AutoFit 'resize the columns to fit a little better
    End With

    Application.ScreenUpdating = True

    End Sub</pre>

    It is not completely stable as it appears to take a whole lot of memory up. Note the screen won't be refreshed until finished but the scroll bar will still show activity.

    Next thing you will want error checking!
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  8. #8
    Platinum Lounger
    Join Date
    Dec 2000
    Location
    Queanbeyan, New South Wales, Australia
    Posts
    3,730
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: print font macro

    Andrew,

    It will go a lot faster inserting the characters this way:
    <pre>Dim strString As String
    strString = ""
    For iCharNumber = 33 To 255
    strString = strString & Chr(iCharNumber)
    Next iCharNumber
    Selection.InsertAfter strString
    </pre>

    Subway Belconnen- home of the Signboard to make you smile. Get (almost) daily updates- follow SubwayBelconnen on Twitter.

  9. #9
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,853
    Thanks
    4
    Thanked 259 Times in 239 Posts

    Re: print font macro

    By Geoff your right again

    Here is the faster version
    <pre>Sub PrintFontList()
    Dim iCharNumber As Integer
    Dim iNumberOfFonts As Integer, i As Integer
    Dim vFontName As Variant
    Dim strString As String

    strString = ""
    For iCharNumber = 33 To 255
    strString = strString & Chr(iCharNumber)
    Next iCharNumber

    Documents.Add 'create a new document
    ActiveDocument.Tables.Add Range:=Selection.Range, _
    NumRows:=1, NumColumns:=2

    'Application.ScreenUpdating = False

    For Each vFontName In FontNames
    With Selection
    .Font.NAME = "Arial"
    .InsertAfter vFontName
    .MoveRight Unit:=wdCell
    .Font.NAME = vFontName
    .InsertAfter strString
    .MoveRight Unit:=wdCell
    End With
    Next vFontName

    With ActiveDocument.Tables(1)
    .Rows(.Rows.count).Delete 'remove the last empty row
    .Sort SortOrder:=wdSortOrderAscending ' sort on the first column
    .Columns.AutoFit 'resize the columns to fit a little better
    End With

    'Application.ScreenUpdating = True
    End Sub</pre>

    Any more improvements gratefully accepted
    Andrew Lockton, Chrysalis Design, Melbourne Australia

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •