frog.raindrop.jp.knowledge

おまけ
EnumFontFamilies コールバックインターフェースセット 笑。
IEnumFontFamiliesCallback をオブジェクトモジュールにインプリメントするだけ。引数は適当にいじくって使いましょう。

' EnumFontFamilies.bas
Option Explicit

Private Const mcstrMODULE_NAME  As String = "EnumFontFamilies"

Private Const LF_FACESIZE       As Long = 32&
Private Const LF_FULLFACESIZE   As Long = 64&

Private Const DEVICE_FONTTYPE   As Long = &H2&
Private Const RASTER_FONTTYPE   As Long = &H1&
Private Const TRUETYPE_FONTTYPE As Long = &H4&

Private Const DEFAULT_CHARSET   As Long = 1&

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 TEXTMETRIC
        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
End Type
Private Type ENUMLOGFONT
        elfLogFont As LOGFONT
        elfFullName(LF_FULLFACESIZE - 1&) As Byte
        elfStyle(LF_FACESIZE - 1&) As Byte
End Type

Private Type ENUMLOGFONTEX
        elfLogFont As LOGFONT
        elfFullName(LF_FULLFACESIZE - 1&) As Byte
        elfStyle(LF_FACESIZE - 1&) As Byte
        elfScript(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
Private Type FONTSIGNATURE
        fsUsb(4) As Long
        fsCsb(2) As Long
End Type
Private Type NEWTEXTMETRICEX
        ntmTm As NEWTEXTMETRIC
        ntmFontSig As FONTSIGNATURE
End Type

Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, lParam As Any, ByVal dw As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


Public Sub EnumFontFamilies(ByVal plngHandleOfDc As Long, pstrFacename As String, pfrmOwner As IEnumFontFamiliesCallback)
'============= Declare ==============
Dim lngRet              As Long
Dim udtLogFont          As LOGFONT
Dim bytBuf()            As Byte

'============= Initiarize ===========
On Error GoTo EnumFontFamilies_E00
    
'============= Main =================

    bytBuf = StrConv(pstrFacename, vbFromUnicode)
    
    With udtLogFont
        .lfCharSet = DEFAULT_CHARSET
        Call MoveMemory(.lfFaceName(0), bytBuf(0), UBound(bytBuf) + 1&)
        .lfPitchAndFamily = 0&
    End With
    
    lngRet = EnumFontFamiliesEx(plngHandleOfDc, udtLogFont, AddressOf EnumFontFamExProc, ByVal ObjPtr(pfrmOwner), 0&)
    
'============= Release ==============
EnumFontFamilies_L00:
    Exit Sub
'============= Error ================
EnumFontFamilies_E00:
    Call Err.Raise(vbObjectError Or Err.Number, mcstrMODULE_NAME & ".EnumFontFamilies" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

    Resume EnumFontFamilies_L00
End Sub

Private Function EnumFontFamExProc(lpelfe As ENUMLOGFONTEX, ByVal lpntme As Long, ByVal FontType As Long, ByVal lParam As IEnumFontFamiliesCallback) As Long
'============= Declare ==============
Dim strFullname         As String
Dim strStyle            As String
Dim strScript           As String
Dim udtTextMetric       As TEXTMETRIC
Dim udtNewTextMetric    As NEWTEXTMETRICEX

'============= Initiarize ===========
On Error GoTo EnumFontFamExProc_E00
    EnumFontFamExProc = True    ' 列挙を続ける
    
'============= Main =================
    
    With lpelfe
        strFullname = StrConv(.elfFullName, vbUnicode)
        strStyle = StrConv(.elfStyle, vbUnicode)
        strScript = StrConv(.elfScript, vbUnicode)
    End With
    If FontType And TRUETYPE_FONTTYPE Then
        Call MoveMemory(udtNewTextMetric, ByVal lpntme, Len(udtNewTextMetric))
    Else
        Call MoveMemory(udtTextMetric, ByVal lpntme, Len(udtTextMetric))
    End If
    
    Call lParam.EnumFontFamiliesCallback(Left$(strFullname, InStr(strFullname, vbNullChar) - 1&), Left$(strStyle, InStr(strStyle, vbNullChar) - 1&), Left$(strScript, InStr(strScript, vbNullChar) - 1&))
    
'============= Release ==============
EnumFontFamExProc_L00:
    Exit Function
'============= Error ================
EnumFontFamExProc_E00:
    Call MsgBox(mcstrMODULE_NAME & ".EnumFontFamExProc" & "(" & Err.Source & ")" & vbCrLf & Format$(Err.Number, "0""=""") & Err.Description, vbCritical)

    Resume EnumFontFamExProc_L00
End Function

' IEnumFontFamiliesCallback.cls
Private Const mcstrMODULE_NAME  As String = "IEnumFontFamiliesCallback"
Option Explicit

Public Sub EnumFontFamiliesCallback(pstrFacename As String, pstrStyle As String, pstrScript As String)

End Sub