Beispiel:

Option Explicit
 
Public Enum FONT_TYPES
  VECTOR_FONTTYPE = &H0
  RASTER_FONTTYPE = &H1
  DEVICE_FONTTYPE = &H2
  TRUETYPE_FONTTYPE = &H4
  ALL_FONTTYPES = (-1)
End Enum
 
Public Const LF_FACESIZE                  As Long = 32
 
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
  lfsFaceName(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
 
Public Declare Function GetDC _
    Lib "user32" _
    (ByVal hwnd As Long) As Long
 
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 ReleaseDC _
    Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal hdc As Long) As Long
 
Public Declare Function GetActiveWindow _
    Lib "user32" () As Long
 
Dim g_lSelectedFontType As Long
Dim g_lFontsCounter     As Long
 
Public Function GetFontList( _
                vFonts As Variant, _
                Optional lFontType _
                As FONT_TYPES = ALL_FONTTYPES) _
                As Long
  '// -----------------------------------------------------
  '// Methode:   | Alle Schriften ermitteln; benötigt
  '//            |  Callback-Funktion EnumFontFamProc
  '// -----------------------------------------------------
  '// Parameter: | vFonts - Variant-(Array) für die Schrift
  '//            | lFontType - zu ermittelnde Kategorie
  '// -----------------------------------------------------
  '// Rückgabe:  | s.o.
  '// -----------------------------------------------------
  '// Beispiel:  | Alle TrueType-Schriften ermitteln
  '// -----------------------------------------------------
  '// Autor:     | Stefan Kulpa
  '//            | EDV Innovation & Consulting - Dormagen
  '// -----------------------------------------------------
  '// Dim vFonts() As Variant
  '// Dim lResult As Long, lCount As Long
  '// lResult = GetFontList(vFonts, TRUETYPE_FONTTYPE)
  '// For lCount = 0 To lResult
  '//     Debug.Print vFonts(lCount)
  '// Next
  '// Erase vFonts
  '// -----------------------------------------------------
  Dim lhWnd   As Long
  Dim hdc     As Long
 
  lhWnd = GetActiveWindow()
  hdc = GetDC(lhWnd)
  '// -----------------------------------------------------
  '// Alle Schriften ermitteln
  '// -----------------------------------------------------
  g_lSelectedFontType = lFontType
  g_lFontsCounter = 0
  ReDim vFonts(0 To 0)
  EnumFontFamilies hdc, vbNullString, _
      AddressOf EnumFontFamProc, vFonts
  ReleaseDC lhWnd, hdc
  '// -----------------------------------------------------
  '// Rückgabewert für die Funktion weiterleiten
  '// -----------------------------------------------------
  GetFontList = g_lFontsCounter
 
End Function
 
Public Function EnumFontFamProc( _
                lpNLF As LOGFONT, _
                lpNTM As NEWTEXTMETRIC, _
                ByVal FontType As Long, vArray) As Long
  '// -----------------------------------------------------
  '// Callback-Funktion!
  '// Diese Funktion muss sich in einem Modul befinden!!!
  '// -----------------------------------------------------
  Dim sFaceName As String
  sFaceName = StrConv(lpNLF.lfsFaceName, vbUnicode)
  sFaceName = Left$(sFaceName, InStr(sFaceName, vbNullChar) - 1)
  If Len(sFaceName) > 0 Then
    If (g_lSelectedFontType = ALL_FONTTYPES) Or _
        (g_lSelectedFontType = FontType) Then
      g_lFontsCounter = g_lFontsCounter + 1
      ReDim Preserve vArray(g_lFontsCounter)
      vArray(g_lFontsCounter - 1) = sFaceName
    End If
  End If
  EnumFontFamProc = 1
 
End Function