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
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>