| Prerequisites |
| Visual Basic 5/6. |
|
 With
the advent of callback support via the AddressOf method in VB5 and VB6, a wealth of previously unavailable APIs can now be added to the VB
programming arsenal.
Based on the example provided in the VB5 help file, this page details the minimum code required to implement a callback for the
EnumFontFamilies API used in Win9x, and NT4/2000/XP. For comparison of the speed in using the callback approach, a second listbox is populated
using the native VB Screen.Font() method using a for ... next loop. |
|
| 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 Function EnumFontFamProc(lpNLF As LOGFONT, _
lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, _
LParam As ListBox) As Long
Dim FaceName As String
'convert the returned string from Unicode to ANSI
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
'add the font to the list
LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
'return success to the call
EnumFontFamProc = 1
End Function |
|
| Form
Code |
|
| On Form1 as shown in the above illustration, add a two list
boxes (List1 and List2), two command buttons (Command1 and Command2) and two labels (label1 and Label2). Add the following code to the form: |
|
Option Explicit Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
End Sub
Private Sub Command1_Click()
Dim hDC As Long
'Add system fonts using a callback
List1.Clear
'Add the fonts using the API and callback by calling
'the EnumFontFamilies API, passing the AddressOf the
'application-defined callback procedure EnumFontFamProc
'and the list to fill
EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamProc, List1
'indicate the fonts found
Label1.Caption = List1.ListCount & " fonts"
End Sub
Private Sub Command2_Click()
Dim cnt as Integer
List2.Clear
'Add the screen fonts the VB-way
For cnt = 0 To Screen.FontCount -1
List2.AddItem Screen.Fonts(cnt)
Next
'indicate the fonts found
Label2.Caption = List2.ListCount & " fonts"
End Sub |
|
| Comments |
Run the project, and click both command buttons. Notice
how much quicker the API method is, especially as the number of fonts installed increases. A combo box can be substituted in the Command1
routine by changing the 4 instances of List1.
Note too that the callback returns 1 each time it is called. Returning 0 terminates the API call. |
|
