Visual Basic Enumeration/Callback Routines

EnumFontFamilies: Enumerate Windows Fonts with Font Preview
Posted:   Wednesday April 9, 1997
Updated:   Monday December 26, 2011
Applies to:   VB5, VB6
Developed with:   VB5, Windows 95
OS restrictions:   None
Author:   VBnet - Randy Birch


EnumFontFamilies: Enumerating Windows Fonts by Type
EnumFontFamilies: Enumerating Windows Fonts - Callback vs. VB Intrinsic Code
Visual Basic 5/6.

vbnsfontcallback3.gif (6198 bytes)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

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

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


PayPal Link
Make payments with PayPal - it's fast, free and secure!


Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy


Hit Counter