Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private 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 - 1) As Byte
End Type

Private 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 EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, LParam As Any) As Long

Private Const TRUETYPE_FONTTYPE = &H4      'TrueTypeフォント

'---------------------------------------------------------------------------
' 関数名： EnumFontFamTypeProc
' 機能 ： TrueTypeフォント名を列挙する
' 引数 ： (in)lpNLF … LOGFONT構造体
'         (in)lpNTM … NEWTEXTMETRIC構造体
'         (in)FontType … フォントタイプ
'         (in)LParam … EnumFontFamilies関数の第４引数に指定した値
' 返り値： 常にTrue
'---------------------------------------------------------------------------
Public Function EnumFontFamTypeProc(ByRef lpNLF As LOGFONT, _
                          ByRef lpNTM As NEWTEXTMETRIC, _
                          ByVal FontType As Long, ByVal LParam As Long) As Long

    Dim FaceName As String

    If FontType = TRUETYPE_FONTTYPE Then
        'FaceName を UniCode から ANSI に変換
        FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
        'NULLまで取得
        Debug.Print Left$(FaceName, InStr(FaceName, Chr$(0)) - 1)
    End If

    '列挙を継続
    EnumFontFamTypeProc = True

End Function

呼び出し側ロジック。

Private Sub Command1_Click()

    Call EnumFontFamilies(Me.hDC, vbNullString, AddressOf EnumFontFamTypeProc, ByVal 1&)

End Sub