A Faster Font List/Combo

Create a from with a combo box, Combo1, and put the following code in the form's code window:

Option Explicit

Private Sub Form_Load()
  Module1.FillComboWithFonts Combo1
End Sub

Add a module, Module1, to the project and add the following code to the module.

Option Explicit

'Font enumeration types
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

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

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

Declare Function EnumFontFamilies Lib "gdi32" Alias _
   "EnumFontFamiliesA" _
   (ByVal hDC As Long, ByVal lpszFamily As String, _
   ByVal lpEnumFontFamProc As Long, LParam As Any) As Long Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
   ByVal hDC As Long) As Long

Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
   ByVal FontType As Long, LParam As ListBox) As Long
Dim FaceName As String
Dim FullName As String
  FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
  LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
  EnumFontFamProc = 1

End Function

Sub FillComboWithFonts(CB As ComboBox)
Dim hDC As Long
  CB.Clear
  hDC = GetDC(CB.hWnd)
  EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, CB
  ReleaseDC CB.hWnd, hDC
End Sub

You can change the combo box's Sorted property to True if you want the font list to be sorted. The code will work also with listboxes if you make the appropriate changes from ComboBox to ListBox.

There you have it, a faster and better way to add fonts to a combo box.