Results 1 to 9 of 9
  1. #1
    Lounger
    Join Date
    Jan 2001
    Posts
    27
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Font inventory samples (Word 2000)

    Is there a way to print all my available fonts? I want to print an example of every letter of the alphabet both upper and lower case and the numerics for each font. I know I did this once long ago but can't remember how. I am looking for a method other than the obvious onw of creating a document with all the fonts by hand.

  2. #2
    Plutonium Lounger
    Join Date
    Nov 2001
    Posts
    10,550
    Thanks
    0
    Thanked 7 Times in 7 Posts

    Re: Font inventory samples (Word 2000)

    Here's the Macro I use to do this job, you may want to change the displayed text to match your requirements.

    StuartR

    Public Sub AllFonts()
    Dim strBaseFont As String
    Dim strFont As Variant

    With Selection.ParagraphFormat
    .Alignment = wdAlignParagraphLeft
    .LeftIndent = 0
    .RightIndent = 0
    .SpaceBefore = 1
    .SpaceAfter = 0
    .LineSpacingRule = wdLineSpaceSingle
    .WidowControl = True
    .KeepTogether = True
    .KeepWithNext = True
    End With
    strBaseFont = "Times New Roman"
    For Each strFont In Application.FontNames
    Selection.Font.Name = strBaseFont
    Selection.TypeText strFont & vbCrLf
    Selection.Font.Name = strFont
    Selection.TypeText "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890" & vbCrLf
    Selection.TypeText "The quick brown fox jumps over the lazy dog's back" & vbCrLf
    Selection.TypeText "! @ #$ % ^ & *() _ + - = { } [ ] : ;<>?,./|~`" & vbCrLf
    Selection.ParagraphFormat.KeepWithNext = False
    Selection.TypeText vbCrLf
    Selection.ParagraphFormat.KeepWithNext = True
    Next strFont

  3. #3
    Lounger
    Join Date
    Jan 2001
    Posts
    27
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Font inventory samples (Word 2000)

    Your macro works wonderfully. How would I set the font size of each sample font in the generated document?

  4. #4
    Lounger
    Join Date
    Jan 2001
    Posts
    27
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Font inventory samples (Word 2000)

    One more thing. How would I add a line to each font sample showing it in Italics?

  5. #5
    Plutonium Lounger
    Join Date
    Nov 2001
    Posts
    10,550
    Thanks
    0
    Thanked 7 Times in 7 Posts

    Re: Font inventory samples (Word 2000)

    This is a pretty old macro that I had lying around, I would probably write it completely differently if I were going to start now.

    To display a line of italics you can add
    Selection.Font.Italic = True
    Selection.TypeText "The quick brown fox jumps over the lazy dog's back" & vbCrLf
    Selection.Font.Italic = False
    at the obvious point in the Macro

    To change the font size why don't you just select the whole document and change the size to whatever you need?
    Alternatively you can add
    Selection.Font.Size = 36 (or whatever) and then add a line of text in that size, followed by Selection.Font.Size = 12 again
    Replace the 36 and 12 with whatever numbers work best for you.

    StuartR

  6. #6
    Lounger
    Join Date
    Jan 2001
    Posts
    27
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Font inventory samples (Word 2000)

    Thanks for your suggestions. It works marvelously.

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

    Re: Font inventory samples (Word 2000)

    Stuart has solved your problem already but here is another possible solution that addresses an oddity of how that macro works - namely the list is not sorted alphabetically by typeface. I suspect it is sorted by font ID but I really have now idea on what the methodology is.

    Note this macro is a lot slower than Stuart's provided code but it does sort the output so I think the time hit is worth it.
    <pre>Sub CreateFontList()
    Dim iCharNumber As Integer, iNumberOfFonts As Integer, I As Integer
    Dim aFontName As Variant, aFontTable As Table
    Dim sString As String

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

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

    For Each aFontName In FontNames
    With Selection
    .Font.Name = "Arial"
    .InsertAfter aFontName
    .MoveRight Unit:=wdCell
    .Font.Name = aFontName
    .InsertAfter sString
    .MoveRight Unit:=wdCell
    End With
    Next aFontName

    With aFontTable
    .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
    'move to the top of file
    Selection.HomeKey Unit:=wdStory
    End Sub</pre>

    Andrew Lockton, Chrysalis Design, Melbourne Australia

  8. #8
    Super Moderator jscher2000's Avatar
    Join Date
    Feb 2001
    Location
    Silicon Valley, USA
    Posts
    23,112
    Thanks
    5
    Thanked 93 Times in 89 Posts

    Re: Font inventory samples (Word 2000)

    I wanted to send someone a list showing her name in all the fonts I can use in Photoshop Elements. Word seemed to be the best tool. Since the text was short, I used two columns, and added some code to get rid of symbol fonts automatically (I only found one way to reliably do this, as shown in the code). Here's the current version... subject to change!
    <pre>Sub MakeFontSampler()
    ' Borrows from CreateFontList() in post#238671
    Dim sString As String, docNew As Document
    Dim styCaption As Style, aFontName As Variant
    ' Get brief text string from user
    sString = InputBox("Enter brief text to use for font samples " & _
    "(blank to quit)", , "Welcome!")
    If Len(Trim(sString)) = 0 Then Exit Sub
    ' Create new document and fill it with samples
    Set docNew = Documents.Add 'just use Normal template
    ' Create style for font names
    Set styCaption = docNew.Styles.Add("FontName", wdStyleTypeCharacter)
    With styCaption.Font
    .Name = "Arial Narrow"
    .Size = "11"
    End With
    ' Set margins and columns
    With docNew.PageSetup
    .TopMargin = InchesToPoints(1)
    .BottomMargin = InchesToPoints(1)
    .LeftMargin = InchesToPoints(0.5)
    .RightMargin = InchesToPoints(0.5)
    End With
    With docNew.ActiveWindow.View 'set print layout view
    If .SplitSpecial <> wdPaneNone Then docNew.ActiveWindow.Panes(2).Close
    If .Type <> wdPrintView Then docNew.ActiveWindow.ActivePane.View.Type = wdPrintView
    End With
    With docNew.PageSetup.TextColumns
    .SetCount NumColumns:=2
    .EvenlySpaced = True
    .LineBetween = True
    .Width = InchesToPoints(3.6)
    .Spacing = InchesToPoints(0.3)
    End With
    ' Set tab that will govern all paragraphs
    docNew.Paragraphs(1).TabStops.Add Position:=InchesToPoints(3.5), Alignment:=wdAlignTabRight
    ' Loop through all fonts and spray out samples
    With docNew.ActiveWindow.Selection
    For Each aFontName In Application.FontNames
    .Font.Reset
    .TypeParagraph
    .Font.Name = aFontName
    .Font.Size = "25"
    .TypeText sString
    .MoveUp wdParagraph
    'Check for and delete fonts Word treats as symbol fonts; weird unicode values
    If AscW(.Text) <> AscW(sString) Then 'First characters don't match!
    .MoveEnd wdParagraph
    .MoveStart wdCharacter, -1
    .Delete
    Else
    .Style = "FontName"
    .TypeText aFontName & ":" & vbTab
    .MoveDown wdParagraph 'Moves to end of paragraph
    End If
    Next aFontName
    End With
    With docNew
    ' Sort by font name
    .Content.Sort excludeheader:=True
    ' Move to the top of file and display it
    .Activate
    .ActiveWindow.Selection.HomeKey Unit:=wdStory
    End With
    If Not (docNew Is Nothing) Then Set docNew = Nothing
    End Sub
    </pre>

    Thanks to Andrew and Stuart for showing the way.

  9. #9
    3 Star Lounger
    Join Date
    Apr 2004
    Location
    Boston, Massachusetts, USA
    Posts
    389
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Font inventory samples (Word 2000)

    Couldn't help but put in my 2 cents ...

    You can reduce the performance hit by waiting until all the text is inserted before making it into a table (which you can then sort).

    This is straight from Chapter 3 of Word Hacks (can't resist a chance to plug the book either).

    <pre>Sub FontSampleTable()
    Dim vFontName As Variant
    Dim iFontCount As Integer
    Dim i As Integer
    Dim tbl As Table
    Dim sSampleText As String
    Dim doc As Document
    Dim rng As Range

    sSampleText = "abcdefghijklmnopqrstuvwxyz"
    sSampleText = sSampleText & Chr$(32) & UCase(sSampleText)
    sSampleText = sSampleText & Chr$(32) & "0123456789"
    sSampleText = sSampleText & Chr$(32) & ",.:;!@#$%^&*( )"
    Application.ScreenUpdating = False

    Set doc = Documents.Add
    iFontCount = Application.FontNames.count

    Set rng = doc.Range
    rng.Font.Name = "Times"
    rng.InsertAfter ("Font Name" & vbTab & "Sample" & vbCr)
    i = 1
    For Each vFontName In Application.FontNames
    StatusBar = "Preparing Sample " & i & " of " & _
    iFontCount & " available fonts: " & vFontName
    rng.Collapse wdCollapseEnd
    rng.InsertAfter (vFontName & vbTab & sSampleText & vbCr)
    rng.Font.Name = vFontName
    i = i + 1
    Next vFontName

    StatusBar = "Formatting Sample Table ... Please Wait"

    doc.Content.ConvertToTable Format:=wdTableFormatWeb1
    Set tbl = doc.Tables(1)

    tbl.Rows.First.Range.Font.Bold = True
    tbl.Rows.First.HeadingFormat = True
    tbl.Columns.First.Select

    Selection.Font.Name = "Times"
    Selection.Rows.AllowBreakAcrossPages = False
    Selection.Collapse wdCollapseStart

    tbl.SortAscending

    StatusBar = "Done"
    Application.ScreenUpdating = True
    End Sub
    </pre>


Posting Permissions

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