[VBnet Enum/Callback] EnumFontFamilies: Enumerating Windows Fonts by Type

	Visual Basic Enumeration/Callback Routines EnumFontFamilies: Enumerating Windows Fonts by Type

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

Related:	EnumFontFamilies: Enumerating Windows Fonts - Callback vs. VB Intrinsic Code EnumFontFamilies: Enumerate Windows Fonts with Font Preview

Prerequisites

Visual Basic 5/6.

This page shows the code required to add to a listbox only the specifictypes of fonts desired. Windows supports four font type - Vector (such as Modern), Raster (MS Sans Serif), Device-Specific (such as PostScript), and TrueType.

By comparing the returned value from the callback to one of these 4 constants, the listbox can be restricted to only those fonts matching the desired type.

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

'set via Option1
Public ShowFontType 
 
'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 EnumFontFamTypeProc(lpNLF As LOGFONT, _
                                    lpNTM As NEWTEXTMETRIC, _
                                    ByVal FontType As Long, _
                                    lParam As ListBox) As Long

   Dim FaceName As String
   
   If ShowFontType = FontType Then
        
     '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)
 
   End If 
   
  'return success to the call   
   EnumFontFamTypeProc = 1

End Function

Form Code

On Form1 as shown in the illustration, add a list box (List1), a command button (Command1) and a label (Label1).

Add a control array of option buttons (Option1()), setting the indexes to 0, 1, 2 and 4, to correspond to the constants defined for the EnumFonts Masks (skip index '3').

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 EnumFontFamTypeProc, List1
   
  'indicate the fonts found   
   Label1.Caption = List1.ListCount & " fonts"

End Sub


Private Sub Option1_Click(Index As Integer)
   
  'set the font type flag   
   ShowFontType = Index
   
  'reflect the selection in the button caption   
   Command1.Caption = "Enum " & Option1(Index).Caption
    
End Sub

Comments

The constant VECTOR_FONTTYPE used above is mine; there is no Vector type defined in the API viewer. However, the MSDN states that this font type constant is 0.

Note as well that (at least on my system) Modern shows up as both a Vector and as a Device font.

PayPal Link