| Prerequisites |
| Visual Basic 5/6. |
|
 This
is the code required to enumerate the system fonts into a listbox using a callback routine, and provide a sizeable preview of the font
selected.
Font sample sizing is via a vertical scrollbar. But because a
scrollbar normally increments as the slider moves down, I changed this behaviour to a more logical state, that is, as the slider is lowered,
the text is smaller.
Changing this behaviour is affected by subtracting the current
scrollbar value from the maximum scrollbar value plus the smallest allowable value. The DisplaySample routine shows this. |
|
| BAS
Module Code |
|
| Place the following code into the general declarations
area of a bas module: |
|
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Font enumeration types
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
Public Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Public Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
'ntmFlags field flags
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
'tmPitchAndFamily flags
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
'EnumFonts Masks
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Declare Function EnumFontFamilies Lib "gdi32" _
Alias "EnumFontFamiliesA" _
(ByVal hDC As Long, _
ByVal lpszFamily As String, _
ByVal lpEnumFontFamProc As Long, _
lParam As Any) As Long
Public Declare Function GetDC Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Public Function EnumFontFamDisplayProc(lpNLF As LOGFONT, _
lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, _
lParam As ListBox) As Long
'This callback function is identical to
'EnumFontFamProc the example on Enumerating
'Fonts, except that it also stores the
'FontType as the list item's ItemData.
Dim FaceName As String
Dim FaceType As String
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
'Add the font to the list
lParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
'Add the FontType to the listbox ItemData property
lParam.ItemData(lParam.NewIndex) = FontType
'return success to the call
EnumFontFamDisplayProc = 1
End Function |
|
| Form
Code |
|
| On Form1 as shown in the illustration, add a list box
(List1), a command button (Command1) and three labels (Label1, Label2 and Label3). Add a picturebox (Picture1) and a vertical scroll bar
control (VScroll1). Set the VScroll1 Max property to 120, and the Min property to 8. Add a textbox (Text1) containing the text to display for
the font sample. Add the following code to the form: |
|
Option Explicit Dim SampleText As String
Private Sub Command1_Click()
Dim hDC As Long
List1.Clear
'Add the fonts using the API and callback
'by calling the EnumFontFamilies API, passing
'the AddressOf the application-defined callback
'procedure EnumFontFamDisplayProc and the list to fill
EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamDisplayProc, List1
'indicate the fonts found
Label1.Caption = List1.ListCount & " fonts"
End Sub
Private Sub Form_Load()
Text1.Text = "Sample"
Label2.Caption = ""
Label3.Caption = ""
End Sub
Private Sub List1_Click()
If List1.ListIndex > -1 Then DisplaySample
End Sub
Private Sub Text1_Change()
SampleText = Text1.Text
End Sub
Private Sub VScroll1_Change()
If List1.ListIndex > -1 Then DisplaySample
End Sub
Private Sub DisplaySample()
Dim fType As String
Dim value As Integer
'Determine the point size to display.
'Because scrollbar's normally increment
'Modify the scrollbar behaviour by subtracting
'the current scrollbar value from the
'maximum scrollbar value + the smallest value.
'In this case, the largest value is 120 (points),
'the smallest is 8 (points), so the expression is:
value = 128 - VScroll1.value
Picture1.FontSize = value
'Based on the value stored in the ListIndex property,
'select the appropriate font description:
Select Case List1.ItemData(List1.ListIndex)
Case RASTER_FONTTYPE: fType = " (Raster)"
Case DEVICE_FONTTYPE: fType = " (Device)"
Case TRUETYPE_FONTTYPE: fType = " (TrueType)"
Case Else: fType = " (Vector)"
End Select
'Clear and show the appropriate font
Picture1.Cls
'Set the pix box font
Picture1.FontName = List1.List(List1.ListIndex)
Picture1.Print SampleText
'Indicate the current font attributes
Label2.Caption = value & " point"
Label3.Caption = Picture1.FontName & fType
End Sub |
|
| Comments |
| Run the project, load the font list and select a
font. It will be displayed as the sample font at the size set by the scrollbar. |
|
