print font macro

Topic

New Reply

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.

Reply | Quote

Replies

Try this one

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

Reply | Quote

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

Reply | Quote

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.

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

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!

Reply | Quote

Andrew,

It will go a lot faster inserting the characters this way:

Dim strString As String
    strString = ""
    For iCharNumber = 33 To 255
        strString = strString & Chr(iCharNumber)
    Next iCharNumber
    Selection.InsertAfter strString

Reply | Quote

By Geoff your right again

Here is the faster version

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

Any more improvements gratefully accepted

Reply | Quote

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.

Reply | Quote

Hi Phil,

These are certainly nice, but are for printing lists of styles, not lists of fonts.

Reply | Quote

Oops. Thanks for catching that.

Reply | Quote