[VBA] GDI+ Flat API で System.Drawing.Text.PrivateFontCollection を呼び出す

PrivateFontCollection.bas

' ThisWorkbook モジュール
Option Explicit

Private Const LF_FACESIZE As Long = 32&
Private Const LANG_NEUTRAL As Integer = 0

Private Const NullPtr As LongPtr = 0
Public m_GDIplusToken As LongPtr
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (ByRef token As LongPtr, ByRef inputBuf As GdiplusStartupInput, Optional ByVal outputBuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipNewPrivateFontCollection Lib "GDIPlus" (ByRef fontCollection As LongPtr) As Long
Private Declare PtrSafe Function GdipPrivateAddFontFile Lib "GDIPlus" (ByVal fontCollection As LongPtr, ByVal filename As LongPtr) As Long
Private Declare PtrSafe Function GdipDeletePrivateFontCollection Lib "GDIPlus" (ByRef fontCollection As LongPtr) As Long
Private Declare PtrSafe Function GdipGetFontCollectionFamilyCount Lib "GDIPlus" (ByVal fontCollection As LongPtr, ByRef numFound As Long) As Long
Private Declare PtrSafe Function GdipGetFontCollectionFamilyList Lib "GDIPlus" (ByVal fontCollection As LongPtr, ByVal numSought As Long, ByRef gpfamilies As LongPtr, ByRef numFound As Long) As Long
Private Declare PtrSafe Function GdipGetFamilyName Lib "GDIPlus" (ByVal family As LongPtr, ByRef familyName As Byte, language As Integer) As Long

'★
Public Sub Main()
    Dim result As Long
    Dim errorMsg As String

    InitializeGDIPlus

    'フォントファイルを指定
    Dim fontFile As String
    'fontFile = "C:\Windows\Fonts\ipamjm.ttf"
    'fontFile = "C:\Windows\Fonts\meiryo.ttc"
    'fontFile = "C:\Windows\Fonts\msmincho.ttc"
    fontFile = "C:\Windows\Fonts\msgothic.ttc"
    
    '「Dim fontCol As New System.Drawing.Text.PrivateFontCollection()」に相当
    Dim fontCol As LongPtr
    result = GdipNewPrivateFontCollection(fontCol)
    If result <> 0 Then
        Err.Raise 51, "GDI+", GetGdipError(result)
        Exit Sub
    End If

    '「fontCol.AddFontFile(fontFile)」に相当
    result = GdipPrivateAddFontFile(fontCol, StrPtr(fontFile))
    If result <> 0 Then
        errorMsg = GetGdipError(result) & vbCrLf & fontFile

        '「fontCol.Dispose()」に相当
        GdipDeletePrivateFontCollection fontCol

        Err.Raise 51, "GDI+", errorMsg
        Exit Sub
    End If

    '「For Each ff As System.Drawing.FontFamily In fontCol.Families」
    Dim familyCount As Long, families() As LongPtr
    result = GdipGetFontCollectionFamilyCount(fontCol, familyCount)
    If result = 0 Then
        ReDim families(0 To familyCount - 1) As Long
        Dim numFound As Long
        result = GdipGetFontCollectionFamilyList(fontCol, familyCount, families(0), numFound)
    End If
    If result <> 0 Then
        errorMsg = GetGdipError(result)
        GdipDeletePrivateFontCollection fontCol
        Err.Raise 51, "GDI+", errorMsg
        Exit Sub
    End If

    '名前を列挙
    Dim n As Long
    Dim familyNames() As String
    Dim buffer() As Byte
    ReDim familyNames(0 To numFound - 1) As String
    For n = 0 To numFound - 1
        ReDim buffer(0 To LF_FACESIZE - 1)
        result = GdipGetFamilyName(families(n), buffer(0), LANG_NEUTRAL)
        familyNames(n) = Split(buffer, vbNullChar, 2)(0)
    Next
    GdipDeletePrivateFontCollection fontCol

    MsgBox Join(familyNames, vbCrLf), vbInformation, fontFile
End Sub

Private Function GetGdipError(ByVal e As Long) As String
    Select Case e
        Case  0: GetGdipError = "Ok"
        Case  1: GetGdipError = "GenericError"
        Case  2: GetGdipError = "InvalidParameter"
        Case  3: GetGdipError = "OutOfMemory"
        Case  4: GetGdipError = "ObjectBusy"
        Case  5: GetGdipError = "InsufficientBuffer"
        Case  6: GetGdipError = "NotImplemented"
        Case  7: GetGdipError = "Win32Error"
        Case  8: GetGdipError = "WrongState"
        Case  9: GetGdipError = "Aborted"
        Case 10: GetGdipError = "FileNotFound"
        Case 11: GetGdipError = "ValueOverflow"
        Case 12: GetGdipError = "AccessDenied"
        Case 13: GetGdipError = "UnknownImageFormat"
        Case 14: GetGdipError = "FontFamilyNotFound"
        Case 15: GetGdipError = "FontStyleNotFound"
        Case 16: GetGdipError = "NotTrueTypeFont"
        Case 17: GetGdipError = "UnsupportedGdiplusVersion"
        Case 18: GetGdipError = "GdiplusNotInitialized"
        Case 19: GetGdipError = "PropertyNotFound"
        Case 20: GetGdipError = "PropertyNotSupported"
        Case 21: GetGdipError = "ProfileNotFound"
        Case Else: GetGdipError = "Error:" & CStr(e)
    End Select
End Function

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not Cancel Then TerminateGDIPlus
End Sub

' https://social.msdn.microsoft.com/Forums/ja-JP/c2db5c2f-16ff-417a-9641-1d2f7da6060d/gdiplusstartup-12392-gdiplusshutdown
Private Sub InitializeGDIPlus()
    If m_GDIplusToken = NullPtr Then
        Dim udt As GdiplusStartupInput
        udt.GdiplusVersion = 1
        GdiplusStartup m_GDIplusToken, udt, NullPtr
    End If
End Sub
Private Sub TerminateGDIPlus()
    If m_GDIplusToken <> NullPtr Then
        GdiplusShutdown m_GDIplusToken
    End If
End Sub

Excel の VBA7 向けのコード。
VB6 や VBA6.5 以下で使う場合には、LongPtr を Long に変更したり、PtrSafe を削除するといった修正が必要。