利用者:Fumiexcel/vb/getglyphtexture

Declare Function GetTextMetrics Lib "gdi32.dll" Alias "GetTextMetricsA" (ByVal hDC As Long, lptm As TEXTMETRIC) As Long
Declare Function GetGlyphOutline Lib "gdi32.dll" _
                                 (ByVal hDC As Long, ByVal uChar As Long, ByVal uFormat As GGOFormatConstants, lpgm As GLYPHMETRICS, _
                                  ByVal cbBuffer As Long, lpvBuffer As Any, lpmat2 As MAT2) As Long    'Alias "GetGlyphOutlineA"
Declare Sub FillMemoryAddr Lib "kernel32" Alias "RtlFillMemory" (ByVal Destination As Long, ByVal length As Long, ByVal Fill As Byte)
Declare Sub CopyMemoryAddr Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, Source As Any, ByVal length As Long)
Type FIXED
    fract As Integer
    Value As Integer
End Type
Type MAT2
    eM11 As FIXED
    eM12 As FIXED
    eM21 As FIXED
    eM22 As FIXED
End Type
Type POINTAPI
    x As Long
    y As Long
End Type
Type GLYPHMETRICS
    gmBlackBoxX As Long
    gmBlackBoxY As Long
    gmptGlyphOrigin As POINTAPI
    gmCellIncX As Integer
    gmCellIncY As Integer
End Type
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
Enum GGOFormatConstants
    GGO_GRAY2_BITMAP = 4
    GGO_GRAY4_BITMAP = 5
    GGO_GRAY8_BITMAP = 6
    GGO_GLYPH_INDEX = 128
End Enum
Public Const GDI_ERROR = -1

Public Function GetGlyphTexture(hDC As Long, Device As Direct3DDevice8, Char As String) As Direct3DTexture8
    Const Level As Integer = 17
    Dim x As Long, y As Long, cx As Long, cy As Long, code As Integer, Size As Long
    Dim pbmp() As Byte '文字のビットマップデータ
    Dim Trans As Long, Color As Long
    Dim GM As GLYPHMETRICS, TM As TEXTMETRIC, mat As MAT2
    Dim LockedRect As D3DLOCKED_RECT 'ロックされたテクスチャのメモリの情報
    Dim bw As Long, bh As Long
    Dim pTexture As Direct3DTexture8
    
        code = Asc(Char) '文字コードの取得
        With mat
        .eM11.Value = 1
        .eM12.Value = 0
        .eM21.Value = 0
        .eM22.Value = 1
        End With
        GetTextMetrics hDC, TM '現在のフォントに関する情報を取得
        Size = GetGlyphOutline(hDC, code, GGO_GRAY4_BITMAP, GM, 0, Null, mat)   'ビットマップのサイズの取得

        If Size = GDI_ERROR Then 'エラーの場合
            Err.Raise Err.LastDllError
        Else
            ReDim pbmp(Size - 1) As Byte
            Call GetGlyphOutline(hDC, code, GGO_GRAY4_BITMAP, GM, UBound(pbmp) + 1, pbmp(0), mat)    'データの取得
        End If

        x = GM.gmptGlyphOrigin.x 'x座標のオフセット
        y = TM.tmAscent - GM.gmptGlyphOrigin.y 'y座標のオフセット
        bw = GM.gmBlackBoxX + (4 - (GM.gmBlackBoxX Mod 4)) Mod 4 'サイズの取得(4の倍数)
        bh = GM.gmBlackBoxY

        Set pTexture = Device.CreateTexture(GM.gmCellIncX, _
                                            TM.tmHeight, _
                                            1, _
                                            0, _
                                            D3DFMT_A8R8G8B8, _
                                            D3DPOOL_MANAGED)   'テクスチャの作成

        pTexture.LockRect 0, LockedRect, Null, D3DLOCK_DISCARD   'ロック

        'FillMemoryAddr LockedRect.pBits, LockedRect.Pitch * TM.tmHeight, 0    'テクスチャサーフェイスの初期化

        For cy = y To y + bh - 1
            For cx = x To x + bw - 1
                Trans = (255 * pbmp(cx - x + bw * (cy - y))) / (Level - 1) '透過レベルの取得
                Color = &HFFFFFF Or LShift(Trans, 24) '色の取得(ARGB)
                CopyMemoryAddr LockedRect.pBits + LockedRect.Pitch * cy + 4 * cx, Color, 4 'メモリに書き込む
            Next
        Next

        pTexture.UnlockRect 0    'ロックの解除
        Set GetGlyphTexture = pTexture
End Function