VB.NETでGetGlyphOutlineを使用するには (ID:146040)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

> [ 環境：VB.NET 2005 ]
VB2005 だと API 版を使うことになりますね。
System.Windows.Media.GlyphTypeface.GetGlyphOutline メソッドは
.NET 3.0 からの実装なので…。

> 使用方法や宣言で間違っているところがありましたら、
ざっと見たところ、宣言部分において
  Int16(UInt16) / Int32(UInt32) / Int64(UInt64)
の使い分けが間違っている気がします。

こんな感じでどうでしょうか。

'-----
Imports System.Runtime.InteropServices
Imports System.IO

Partial Public Class Form1
    Private Declare Function SelectObject Lib "gdi32" _
       (ByVal hdc As IntPtr, _
        ByVal hgdiobj As IntPtr) As IntPtr

Private Declare Function DeleteObject Lib "gdi32" _
        (ByVal hobj As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean

Private Declare Unicode Function GetGlyphOutline Lib "gdi32" _
       (ByVal hdc As IntPtr, _
        ByVal uChar As Integer, _
        ByVal fuFormat As Integer, _
        ByRef lpgm As GLYPHMETRICS, _
        ByVal cbBuffer As Integer, _
        ByVal lpBuffer As IntPtr, _
        ByRef lpmat2 As MAT2) As Integer

Private Declare Unicode Function GetGlyphOutline Lib "gdi32" _
       (ByVal hdc As IntPtr, _
        ByVal uChar As Integer, _
        ByVal fuFormat As Integer, _
        ByRef lpgm As GLYPHMETRICS, _
        ByVal cbBuffer As Integer, _
        ByRef lpBuffer As Byte, _
        ByRef lpmat2 As MAT2) As Integer

<StructLayout(LayoutKind.Sequential, Pack:=4)> _
    Private Structure GLYPHMETRICS
        Public gmBlackBoxX As UInteger      'UINT
        Public gmBlackBoxY As UInteger      'UINT
        Public gmptGlyphOrigin As POINTAPI  'POINT
        Public gmCellIncX As Short          'short
        Public gmCellIncY As Short          'short
    End Structure

<StructLayout(LayoutKind.Sequential, Pack:=4)> _
    Private Structure POINTAPI
        Public x As Integer     'LONG
        Public y As Integer     'LONG
    End Structure

<StructLayout(LayoutKind.Sequential, Pack:=4)> _
    Private Structure MAT2
        Public eM11 As FIXED
        Public eM12 As FIXED
        Public eM21 As FIXED
        Public eM22 As FIXED
    End Structure

<StructLayout(LayoutKind.Sequential, Pack:=4)> _
    Private Structure FIXED
        Public fract As Short   'WORD
        Public value As Short   'short
    End Structure

Private Const GGO_GRAY2_BITMAP As Integer = 4
    Private Const GGO_GRAY4_BITMAP As Integer = 5
    Private Const GGO_GRAY8_BITMAP As Integer = 6
    Private Const GGO_GLYPH_INDEX As Integer = &H80

Private Const GDI_ERROR As Integer = &HFFFFFFFF

Private bmp As Bitmap
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Using bmpDummy As New Bitmap(100, 100), _
              g As Graphics = Graphics.FromImage(bmpDummy), _
              f As New Font("Arial", 12)

Dim hdc As IntPtr = g.GetHdc()
            Dim hFont As IntPtr = f.ToHfont()
            Dim oldFont As IntPtr = SelectObject(hdc, hFont)

Dim mat As MAT2
            With mat
                .eM11.value = 1
                .eM12.value = 0
                .eM21.value = 0
                .eM22.value = 1
            End With

Dim uicharacter As Integer = AscW("a")
            Dim gm As GLYPHMETRICS, dsize As Integer
            dsize = GetGlyphOutline(hdc, uicharacter, GGO_GRAY4_BITMAP, gm, 0, IntPtr.Zero, mat)
            If dsize = GDI_ERROR Then
                MsgBox("エラー:" & CStr(Err.LastDllError))
            Else
                Dim pBMP(dsize - 1) As Byte
                dsize = GetGlyphOutline(hdc, uicharacter, GGO_GRAY4_BITMAP, gm, pBMP.Length, pBMP(0), mat)
                File.WriteAllBytes("C:\RESULT.BIN", pBMP)
            End If

SelectObject(hdc, oldFont)
            DeleteObject(hFont)
            g.ReleaseHdc(hdc)
        End Using
    End Sub
End Class

←解決時は質問者本人がここをチェックしてください。

戻る