print a sheet of font samples for reference.

[Guest]

In Word Art, fonts are not shown in samples. Would like to print a hard copy
of what all the fonts look like for reference purposes.

 

[Steve Yandl]

This subroutine should let you do what you want.

Sub FontPrint()



Dim iCharNumber As Integer, iPointSize As Integer

Dim iNumberOfFonts As Integer

Dim vFontName As Variant

Dim strSample As String

On Error GoTo UserClickedCancel



strSample = "The quick brown fox jumps over the lazy dog"

iPointSize = InputBox("Print Fonts at which point size?", "Steve's Font
List")

On Error GoTo 0

Documents.Add

Selection.TypeText "Fonts presented at " & iPointSize & " points."

Selection.TypeParagraph

Selection.TypeParagraph

For Each vFontName In FontNames

Selection.Font.Size = 11

Selection.Font.Name = "Times New Roman"

Selection.TypeText vFontName

Selection.TypeParagraph

Selection.Font.Size = iPointSize

Selection.Font.Name = vFontName

Selection.TypeText strSample

Selection.TypeParagraph

Selection.TypeParagraph

Next vFontName







Steve Yandl

 

[Guest]

Thank you Steve, but I'm not a programmer and your info totally left me in
the dark. Thanks for trying to help me, though.

 

[JoAnn Paules [MVP]]

There are some macros available on the web. I use one but I don't remember
where I found it.

 

[Steve Yandl]

I actually clipped a few lines off the bottom when I pasted.

Just press Alt plus F8. Fill in a name that makes sense for the macro.
Click the 'Create' button. Do a copy (all between the lines below) and
paste to insert the lines I've got below between the Sub and End Sub lines
that Word will create for you. Close the window. Now, you're back to your
document as usual and you press Alt plus F8 again. Select the macro you
just created and click the run button. You will get a box asking what size
font list you want and when you click OK you will get a new document created
with a sample of each font on your system.

- - ----------------------------------------------------------------------

Dim iCharNumber As Integer, iPointSize As Integer
Dim iNumberOfFonts As Integer
Dim vFontName As Variant
Dim strSample As String
On Error GoTo UserClickedCancel

strSample = "The quick brown fox jumps over the lazy dog"
iPointSize = InputBox("Print Fonts at which point size?", "Steve's Font
List")
On Error GoTo 0
Documents.Add
Selection.TypeText "Fonts presented at " & iPointSize & " points."
Selection.TypeParagraph
Selection.TypeParagraph
For Each vFontName In FontNames
Selection.Font.Size = 11
Selection.Font.Name = "Times New Roman"
Selection.TypeText vFontName
Selection.TypeParagraph
Selection.Font.Size = iPointSize
Selection.Font.Name = vFontName
Selection.TypeText strSample
Selection.TypeParagraph
Selection.TypeParagraph
Next vFontName

UserClickedCancel:

 

[Suzanne S. Barnhill]

See http://word.mvps.org/FAQs/Formatting/FontSampleGenerator.htm

--
Suzanne S. Barnhill
Microsoft MVP (Word)
Words into Type
Fairhope, Alabama USA

Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

 

[Graham Mayor]

There is a font sample generator supplied with Word in the Macros9.dot file
on the installation disc or download that file from
http://office.microsoft.com/downloads/2000/supmacros.aspx

The code it contains is:

Private ptSelection, SampleText As String
Private fname() As String
Private PtSize(42) As String
Private txtHeading1 As String
Private tmn As String
Private tFace As String
Private fsize As String
Private sample1 As String
Private pts As String
Private bigfont As String

Sub FontSampleGenerator()
Dim pos, tmp As Integer
Dim X As Boolean
Dim totfonts, i, j As Integer
InitStrings
totfonts = Application.FontNames.Count
ReDim fname(totfonts - 1)
For i = 0 To totfonts - 1
fname(i) = FontNames(i + 1)
If Left$(fname(i), 1) = "@" Then
End If
Next
BubbleSort fname
Documents.Add
Selection.InsertParagraph
Selection.InsertBefore Text:=txtHeading1
Selection.Font.Size = bigfont
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertParagraph
Selection.Collapse Direction:=wdCollapseEnd
ptSelection = fsize
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=totfonts + 1,
NumColumns:=2
With Selection.Tables(1)
.Rows(1).HeadingFormat = True
.Borders.OutsideLineStyle = wdLineStyleThinThickLargeGap
.Rows.AllowBreakAcrossPages = False
.Columns.Width = InchesToPoints(3#)
End With
With ActiveDocument.Tables(1).Cell(1, 1).Range
.InsertAfter tFace
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Size = fsize
End With
With ActiveDocument.Tables(1).Cell(1, 2).Range
.InsertAfter sample1 & ptSelection & pts
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Size = fsize
End With
For j = 2 To totfonts + 1
DoEvents
If escflag = True Then
Exit Sub
End If
With ActiveDocument.Tables(1).Cell(j, 2).Range
.InsertAfter SampleText
.Font.Name = fname(j - 2)
.Font.Size = fsize
End With
With ActiveDocument.Tables(1).Cell(j, 1).Range
.InsertAfter fname(j - 2)
.Font.Size = fsize
End With
progress = Int(j / (totfonts + 1) * 100) & "% Finished" & vbTab &
fname(j - 2)
Application.StatusBar = progress
Next
Selection.HomeKey Unit:=wdStory
Application.StatusBar = "Done"
End Sub

Function BubbleSort(TempArray As Variant)
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Boolean
'Loop until no more "exchanges" are made
Do
NoExchanges = True
'Loop through each element in the array
For i = 0 To UBound(TempArray) - 1
'If the element is greater than the element
'following it, then exchange the two elements
If TempArray(i) > TempArray(i + 1) Then
NoExchanges = False
Temp = TempArray(i)
TempArray(i) = TempArray(i + 1)
TempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)
End Function

Function InitStrings()
bigfont = "18"
sample1 = "Sample at "
pts = " points"
fsize = "12"

tFace = "TYPEFACE"
tmn = "Times New Roman"

txtHeading1 = "Sample of AVAILABLE TYPEFACES"
SampleText =
"AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789" _
& Chr(34) & Chr(147) & Chr(148) & "@#$%&?!*"
End Function


See http://www.gmayor.com/installing_macro.htm


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web site www.gmayor.com

<>>< ><<> ><<> <>>< ><<> <>>< <>><<>