VB.NETでGetGlyphOutlineを使用するには
解決[ 環境：VB.NET 2005 ]
GetGlyphOutline APIを使用して文字のアウトラインを
取得しようとしているのですが、APIの宣言が悪いのか、
何が悪いのか文字サイズが正しく返ってきません。
使用方法や宣言で間違っているところがありましたら、
ご指摘いただけないでしょうか？
よろしくお願いいたします。
[ 宣言 ]
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As IntPtr) As IntPtr
Public Declare Function GetGlyphOutline Lib "gdi32" Alias "GetGlyphOutlineA" (ByVal hdc As IntPtr, ByVal uChar As Long, ByVal fuFormat As Long, ByRef lpgm As GLYPHMETRICS, ByVal cbBuffer As Long, ByVal lpBuffer As Long, ByRef lpmat2 As MAT2) As Long
Public Structure POINTAPI
Public x As Long
Public y As Long
End Structure
Public Structure GLYPHMETRICS
Public gmBlackBoxX As Long
Public gmBlackBoxY As Long
Public gmptGlyphOrigin As POINTAPI
Public gmCellIncX As Integer
Public gmCellIncY As Integer
End Structure
Public Structure FIXED
Public fract As Integer
Public value As Integer
End Structure
Public Structure MAT2
Public eM11 As FIXED
Public eM12 As FIXED
Public eM21 As FIXED
Public eM22 As FIXED
End Structure
[ 使用箇所 ]
Dim mat As MAT2
Dim uicharacter As Long
Dim dsize As Long
Dim pBMP() As Byte
Dim gm As GLYPHMETRICS
Dim hdc As IntPtr = GetDC(IntPtr.Zero)
With mat
.eM11.value = 1
.eM12.value = 0
.eM21.value = 0
.eM22.value = 1
End With
uicharacter = Asc("a")
'サイズを取得
dsize = GetGlyphOutline(hdc, uicharacter, GGO_GRAY4_BITMAP _
, gm, 0, Nothing, mat)
'このdsizeに巨大な値(283695307298963455)が戻されて
'以下のメモリを確保するところでOverflowExceptionが発生します。
'必要なサイズのメモリを確保
ReDim pBMP(Integer.Parse(dsize.ToString))
'アウトラインを取得
GetGlyphOutline(hdc, uicharacter, GGO_GRAY4_BITMAP, gm _
, dsize, pBMP(0), mat)
以下の宣言でどうでしょう？
Imports System.Runtime.InteropServices
Public Declare Function GetGlyphOutline Lib "gdi32" Alias "GetGlyphOutlineA" _
(ByVal hdc As Integer, ByVal uChar As Integer, ByVal fuFormat As Integer, _
<MarshalAs(UnmanagedType.Struct)> ByRef lpgm As GLYPHMETRICS, _
ByVal cbBuffer As Integer, ByVal lpBuffer As IntPtr, _
<MarshalAs(UnmanagedType.Struct)> ByRef lpmat2 As MAT2) As Integer
<StructLayout(LayoutKind.Sequential)> Public Structure GLYPHMETRICS
Public gmBlackBoxX As Integer
Public gmBlackBoxY As Integer
Public gmptGlyphOrigin As POINTAPI
Public gmCellIncX As Integer
Public gmCellIncY As Integer
End Structure
<StructLayout(LayoutKind.Sequential)> Public Structure POINTAPI
Public x As Integer
Public y As Integer
End Structure
<StructLayout(LayoutKind.Sequential)> Public Structure MAT2
Public eM11 As FIXED
Public eM12 As FIXED
Public eM21 As FIXED
Public eM22 As FIXED
End Structure
<StructLayout(LayoutKind.Sequential)> Public Structure FIXED
Public fract As Integer
Public Value As Integer
End Structure
AE85さんアドバイスありがとうございます。
で、宣言を書換えて試してみました。
GetGlyphOutlineの戻り値が-1(エラー)となりましたので、
GetLastErrorでエラー内容を調べてみたところ、
『1003：この関数を完了できません』
というものが返ってきました。
そこで、もう少し調べると、
http://www.codeguru.com/forum/archive/index.php/t-297308.html
で、この関数を呼ぶ前にTrueTypeFontをセットしなければならない
というのを見つけましたので、ちょっとやってみて結果をまた書込みます。
他に何かアイディアがありましたら
よろしくお願いいたします。
TrueTypeFontをセットしてやってみたのですが、
結果は変わらず、GetGlyphOutlineの戻り値は-1、
GetLastErrorの戻り値は1003でした。
以下、コードです。
Dim gm As GLYPHMETRICS
'フォント作成
Dim fontSize As Integer = 12
Dim lf As [Static].LOGFONT
lf.lfHeight = fontSize
lf.lfWeight = FW_NORMAL
lf.lfCharSet = ANSI_CHARSET
lf.lfOutPrecision = OUT_DEFAULT_PRECIS
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS
lf.lfQuality = DEFAULT_QUALITY
lf.lfPitchAndFamily = FF_SWISS + DEFAULT_PITCH
lf.lfFaceName = "Arial"
Dim hFont As Integer = CreateFontIndirect(lf)
'DC取得
Dim hDC As Integer = GetDC(Nothing) 'プライマリモニタのDC取得
Dim oldFont As Integer = SelectObject(hDC, hFont)
Dim mat As MAT2
With mat
.eM11.Value = 1 '-1にすると左右反転
.eM12.Value = 0
.eM21.Value = 0
.eM22.Value = 1 '-1にすると上下反転
End With
'コード取得
Dim uicharacter As Integer = Asc("a")
'データ格納に必要なサイズを計算
dim dsize as Integer = GetGlyphOutline(hDC, uicharacter _
, GGO_GRAY4_BITMAP, gm, 0, Nothing, mat)
If dsize = -1 Then
Debug.Print("Error=" + GetLastError().ToString)
SelectObject(hDC, oldFont)
DeleteObject(hFont)
ReleaseDC(Nothing, hDC)
DeleteObject(hDC)
hdc = Nothing
Return
End If
> [ 環境：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
魔界の仮面弁士さんありがとうございます。
提示いただいたコードで問題なく動きました＾＾
内容を理解して使用したいと思います。
ありがとうございました。
| ツイート |  |