CreateFontIndirectで正常にFontを取得できない？
解決いつもお世話になっております。
現在、CreateFontIndirect APIを使用して指定したフォントを
取得しようとしているのですが正常に取得できません。
（Defaultでセットされているフォントが選択されてしまう？）
以下のプログラムはForm上にボタン１個作成して、
そのボタンを押下するとフォーム上に"a"と表示されるようなものです。
本当はこれでフォントを変更して表示したりしたいのですが。。。
もし何か心当たりがある方がおられましたら、
大変申し訳ないのですが、教えていただけないでしょうか？
よろしくお願いいたします。
Imports Microsoft.DirectX.Direct3D
Imports System.Runtime.InteropServices
Public Class Form1
Public Enum _D3DTEXTUREOP
' Control
D3DTOP_DISABLE = 1 ' disables stage
D3DTOP_SELECTARG1 = 2 ' the default
D3DTOP_SELECTARG2 = 3
' Modulate
D3DTOP_MODULATE = 4 ' multiply args together
D3DTOP_MODULATE2X = 5 ' multiply and 1 bit
D3DTOP_MODULATE4X = 6 ' multiply and 2 bits
' Add
D3DTOP_ADD = 7 ' add arguments together
D3DTOP_ADDSIGNED = 8 ' add with -0.5 bias
D3DTOP_ADDSIGNED2X = 9 ' as above but left 1 bit
D3DTOP_SUBTRACT = 10 ' Arg1 - Arg2, with no saturation
D3DTOP_ADDSMOOTH = 11 ' add 2 args, subtract product
' Arg1 + Arg2 - Arg1*Arg2
' = Arg1 + (1-Arg1)*Arg2
' Linear alpha blend: Arg1*(Alpha) + Arg2*(1-Alpha)
D3DTOP_BLENDDIFFUSEALPHA = 12 ' iterated alpha
D3DTOP_BLENDTEXTUREALPHA = 13 ' texture alpha
D3DTOP_BLENDFACTORALPHA = 14 ' alpha from D3DRS_TEXTUREFACTOR
' Linear alpha blend with pre-multiplied arg1 input: Arg1 + Arg2*(1-Alpha)
D3DTOP_BLENDTEXTUREALPHAPM = 15 ' texture alpha
D3DTOP_BLENDCURRENTALPHA = 16 ' by alpha of current color
' Specular mapping
D3DTOP_PREMODULATE = 17 ' modulate with next texture before use
D3DTOP_MODULATEALPHA_ADDCOLOR = 18 ' Arg1.RGB + Arg1.A*Arg2.RGB
' COLOROP only
D3DTOP_MODULATECOLOR_ADDALPHA = 19 ' Arg1.RGB*Arg2.RGB + Arg1.A
' COLOROP only
D3DTOP_MODULATEINVALPHA_ADDCOLOR = 20 ' (1-Arg1.A)*Arg2.RGB + Arg1.RGB
' COLOROP only
D3DTOP_MODULATEINVCOLOR_ADDALPHA = 21 ' (1-Arg1.RGB)*Arg2.RGB + Arg1.A
' COLOROP only
' Bump mapping
D3DTOP_BUMPENVMAP = 22 ' per pixel env map perturbation
D3DTOP_BUMPENVMAPLUMINANCE = 23 ' with luminance channel
' This can do either diffuse or specular bump mapping with correct input.
' Performs the function (Arg1.R*Arg2.R + Arg1.G*Arg2.G + Arg1.B*Arg2.B)
' where each component has been scaled and offset to make it signed.
' The result is replicated into all four (including alpha) channels.
' This is a valid COLOROP only.
D3DTOP_DOTPRODUCT3 = 24
' Triadic ops
D3DTOP_MULTIPLYADD = 25 ' Arg0 + Arg1*Arg2
D3DTOP_LERP = 26 ' (Arg0)*Arg1 + (1-Arg0)*Arg2
D3DTOP_FORCE_DWORD = &H7FFFFFFF
End Enum
Public Enum _D3DBLEND
D3DBLEND_ZERO = 1
D3DBLEND_ONE = 2
D3DBLEND_SRCCOLOR = 3
D3DBLEND_INVSRCCOLOR = 4
D3DBLEND_SRCALPHA = 5
D3DBLEND_INVSRCALPHA = 6
D3DBLEND_DESTALPHA = 7
D3DBLEND_INVDESTALPHA = 8
D3DBLEND_DESTCOLOR = 9
D3DBLEND_INVDESTCOLOR = 10
D3DBLEND_SRCALPHASAT = 11
D3DBLEND_BOTHSRCALPHA = 12
D3DBLEND_BOTHINVSRCALPHA = 13
D3DBLEND_BLENDFACTOR = 14 'Only supported if D3DPBLENDCAPS_BLENDFACTOR is on */
D3DBLEND_INVBLENDFACTOR = 15 'Only supported if D3DPBLENDCAPS_BLENDFACTOR is on */
D3DBLEND_SRCCOLOR2 = 16
D3DBLEND_INVSRCCOLOR2 = 17
D3DBLEND_FORCE_DWORD = &H7FFFFFFF 'force 32-bit size enum */
End Enum
Private Const LF_FACESIZE As Int32 = 32
Private FW_NORMAL As Int32 = 400
Private Const SHIFTJIS_CHARSET As Integer = 128 'シフトJIS文字セット
Public Const OUT_DEFAULT_PRECIS As Integer = 0 'デフォルトの方法
Public Const CLIP_DEFAULT_PRECIS As Integer = 0 'デフォルトの方法
Public Const FIXED_PITCH As Integer = 1 '固定ピッチ
Public Const FF_MODERN As Integer = 48 '固定幅ストローク、固定ピッチ、セリフあり・なし
Public Const PROOF_QUALITY As Integer = 2
Public Const GDI_ERROR As Integer = &HFFFFFFFF
Public Const GGO_GRAY4_BITMAP As Integer = 5
Public Const D3DTA_TEXTURE As Integer = &H2 ' select texture color (read only)
Public Const D3DTA_DIFFUSE As Integer = &H0 ' select diffuse color (read only)
<StructLayout(LayoutKind.Sequential, pack:=4)> _
Public Structure LOGFONT
Public lfHeight As Integer
Public lfWidth As Integer
Public lfEscapement As Integer
Public lfOrientation As Integer
Public lfWeight As Integer
Public lfItalic As Byte
Public lfUnderline As Byte
Public lfStrikeOut As Byte
Public lfCharSet As Byte
Public lfOutPrecision As Byte
Public lfClipPrecision As Byte
Public lfQuality As Byte
Public lfPitchAndFamily As Byte
<VBFixedString(LF_FACESIZE)> Public lfFaceName As String
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=4)> _
Public Structure GLYPHMETRICS
Public gmBlackBoxX As UInteger
Public gmBlackBoxY As UInteger
Public gmptGlyphOrigin As POINTAPI
Public gmCellIncX As Short
Public gmCellIncY As Short
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=4)> _
Public Structure POINTAPI
Public x As Integer
Public y As Integer
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=4)> _
Public 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)> _
Public Structure FIXED
Public fract As Short
Public value As Short
End Structure
<StructLayout(LayoutKind.Sequential, pack:=4)> _
Public Structure TEXTMETRIC
Public tmHeight As Integer
Public tmAscent As Integer
Public tmDescent As Integer
Public tmInternalLeading As Integer
Public tmExternalLeading As Integer
Public tmAveCharWidth As Integer
Public tmMaxCharWidth As Integer
Public tmWeight As Integer
Public tmOverhang As Integer
Public tmDigitizedAspectX As Integer
Public tmDigitizedAspectY As Integer
Public tmFirstChar As Byte
Public tmLastChar As Byte
Public tmDefaultChar As Byte
Public tmBreakChar As Byte
Public tmItalic As Byte
Public tmUnderlined As Byte
Public tmStruckOut As Byte
Public tmPitchAndFamily As Byte
Public tmCharSet As Byte
End Structure
Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As IntPtr, _
ByVal hgdiobj As IntPtr) As IntPtr
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean
Public 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
Public 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
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As IntPtr
Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As IntPtr) As IntPtr
Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As IntPtr, ByVal hdc As IntPtr) As IntPtr
Public Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As IntPtr, ByRef lpMetrics As TEXTMETRIC) As Integer
Public Declare Function GetLastError Lib "kernel32" () As Integer
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Dim param As New PresentParameters()
param.Windowed() = True
param.SwapEffect = SwapEffect.Discard
param.PresentationInterval = PresentInterval.Immediate
Using _Device As New Device(0, DeviceType.Hardware, Me, CreateFlags.SoftwareVertexProcessing, param)
'フォント作成
Dim fontSize As Integer = 256
Dim lf As LOGFONT
lf.lfHeight = fontSize
lf.lfWeight = FW_NORMAL
lf.lfCharSet = SHIFTJIS_CHARSET
lf.lfOutPrecision = OUT_DEFAULT_PRECIS
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS
lf.lfQuality = PROOF_QUALITY
lf.lfPitchAndFamily = FIXED_PITCH Or FF_MODERN
lf.lfFaceName = "ＭＳ Ｐゴシック"
Dim hFont As IntPtr = CreateFontIndirect(lf)
'デバイスコンテキスト取得
Dim hDC As IntPtr = GetDC(IntPtr.Zero) 'プライマリモニタのDC取得
Dim oldFont As IntPtr = SelectObject(hDC, hFont)
Using f As System.Drawing.Font = Font.FromHfont(hFont)
Debug.Print(f.ToString)
End Using
'文字コード取得
Dim c As String = "a"
Dim code As Integer = AscW(c)
'フォントビットマップ取得
Dim TM As New TEXTMETRIC
GetTextMetrics(hDC, TM)
Dim GM As GLYPHMETRICS
Dim Mat As MAT2
Mat.eM11.value = 1
Mat.eM12.value = 0
Mat.eM21.value = 0
Mat.eM22.value = 1
Dim size As Integer = GetGlyphOutline(hDC, code, GGO_GRAY4_BITMAP, GM, 0, IntPtr.Zero, Mat)
Dim ptr(0) As Byte
If size = GDI_ERROR Then
MsgBox("エラー:" + GetLastError().ToString, MsgBoxStyle.Exclamation)
Else
ReDim ptr(size)
GetGlyphOutline(hDC, code, GGO_GRAY4_BITMAP, GM, size, ptr(0), Mat)
End If
'デバイスコンテキストとフォアハンドルの解放
SelectObject(hDC, oldFont)
DeleteObject(hFont)
ReleaseDC(IntPtr.Zero, hDC)
'頂点情報
Dim a As Single = 1.0 'テクスチャの縮尺
Dim fTexW As Single = GM.gmCellIncX * a 'テクスチャの横幅
Dim fTexH As Single = TM.tmHeight * a 'テクスチャの高さ
Dim FontColor As Integer = &H88FFFFFF 'テクスチャカラー(透明度50%)
'頂点バッファ作成
Using pVertex As New VertexBuffer(GetType(CustomVertex.TransformedColoredTextured), 4, _Device, Usage.None _
, CustomVertex.TransformedColoredTextured.Format, Pool.Managed)
'頂点情報の書込み
Dim v() As CustomVertex.TransformedColoredTextured = DirectCast(pVertex.Lock(0, 0), CustomVertex.TransformedColoredTextured())
v(0) = New CustomVertex.TransformedColoredTextured(fTexW, 0.0, 0.0, 1.0, FontColor, 1.0, 0.0)
v(1) = New CustomVertex.TransformedColoredTextured(fTexW, fTexH, 0.0, 1.0, FontColor, 1.0, 1.0)
v(2) = New CustomVertex.TransformedColoredTextured(0.0, 0.0, 0.0, 1.0, FontColor, 0.0, 0.0)
v(3) = New CustomVertex.TransformedColoredTextured(0.0, fTexH, 0.0, 1.0, FontColor, 0.0, 1.0)
pVertex.Unlock()
'テクスチャ作成
Dim pTex As Texture
Try
pTex = New Texture(_Device, GM.gmCellIncX, TM.tmHeight, 1, Usage.Dynamic, Format.A8R8G8B8, Pool.Default)
Catch ex1 As Exception
Try
pTex = New Texture(_Device, GM.gmCellIncX, TM.tmHeight, 1, Usage.None, Format.A8R8G8B8, Pool.Managed)
Catch ex As Exception
MsgBox("エラー")
Return
End Try
End Try
'テクスチャにフォントビットマップ書込み
Dim desc As SurfaceDescription = pTex.GetLevelDescription(0)
Dim ipa(1) As Integer
ipa(0) = desc.Height
ipa(1) = desc.Width
Dim buf(,) As UInt32 = DirectCast(pTex.LockRectangle(GetType(UInt32), 0, LockFlags.None, ipa), UInt32(,))
Array.Clear(buf, 0, buf.Length)
Dim iOfs_x As Integer = GM.gmptGlyphOrigin.x
Dim iOfs_y As Integer = TM.tmAscent - GM.gmptGlyphOrigin.y
Dim iBmp_w As Integer = CType(GM.gmBlackBoxX, Integer) + (4 - (CType(GM.gmBlackBoxX, Integer) Mod 4)) Mod 4
Dim iBmp_h As Integer = CType(GM.gmBlackBoxY, Integer)
Dim Level As Integer = 17
Dim x As Integer, y As Integer
Dim Alpha As Long, Color As Long
For y = iOfs_y To (iOfs_y + iBmp_h) - 1
For x = iOfs_x To (iOfs_x + iBmp_w) - 1
Alpha = CType((255 * ptr(x - iOfs_x + iBmp_w * (y - iOfs_y))) / (Level - 1), Long)
Color = &HFFFFFF Or (Alpha << 24)
If y > buf.GetUpperBound(0) OrElse x > buf.GetUpperBound(1) Then
Else
buf(y, x) = CType(Color, UInteger)
End If
Next
Next
pTex.UnlockRectangle(0)
ptr = Nothing
'テクスチャセット
_Device.SetTexture(0, pTex)
_Device.SetTextureStageState(0, TextureStageStates.ColorArgument1, D3DTA_TEXTURE)
_Device.SetTextureStageState(0, TextureStageStates.ColorOperation, _D3DTEXTUREOP.D3DTOP_MODULATE)
_Device.SetTextureStageState(0, TextureStageStates.ColorArgument2, D3DTA_DIFFUSE)
_Device.SetTextureStageState(0, TextureStageStates.AlphaArgument1, D3DTA_TEXTURE)
_Device.SetTextureStageState(0, TextureStageStates.AlphaOperation, _D3DTEXTUREOP.D3DTOP_MODULATE)
_Device.SetTextureStageState(0, TextureStageStates.AlphaArgument2, D3DTA_DIFFUSE) '板ポリのα値を利用
'レンダリングステート
_Device.SetRenderState(RenderStates.AlphaBlendEnable, True)
_Device.SetRenderState(RenderStates.SourceBlend, _D3DBLEND.D3DBLEND_SRCALPHA)
_Device.SetRenderState(RenderStates.DestinationBlend, _D3DBLEND.D3DBLEND_INVSRCALPHA)
'メッセージループ
Do While Me.Created
System.Threading.Thread.Sleep(1)
System.Windows.Forms.Application.DoEvents()
If Me.Created Then
_Device.Clear(ClearFlags.Target, Drawing.Color.Blue, 1.0, 0)
_Device.BeginScene()
_Device.SetStreamSource(0, pVertex, 0)
_Device.VertexFormat = CustomVertex.TransformedColoredTextured.Format
_Device.DrawPrimitives(PrimitiveType.TriangleStrip, 0, 2)
_Device.EndScene()
_Device.Present()
End If
Loop
pTex.Dispose()
End Using
End Using
End Sub
End Class
いきなりソースコードずらずら並べられても読む気がしません。
取り敢えず、
> <VBFixedString(LF_FACESIZE)> Public lfFaceName As String
VBFixedString は VB 関数用の属性であり、アンマネージ関数の呼び出しには関係しません。
アンマネージ関数呼び出し用に固定長文字列を指示する場合、MarshalAs 属性を使い、UnmanagedType.ByValTStr と SizeConst フィールドを使用してください。
ついでに，
MSDN: Windows Font Mapping
http://msdn.microsoft.com/en-us/library/ms969909.aspx
によると，FaceNameよりもFixedPitchの方がペナルティが大きいので，
そこも修正が必要かと思います。
Hongliangさん、YuOさん、
ご指摘ありがとうございました。
お二人のご指摘によりなぜ指定したフォントが取得されないのかが
わかりましたので結果報告します。
Hongliangさんより指摘されたVBFixedStringについてですが、
<VBFixedString(LF_FACESIZE) _
, MarshalAs(UnmanagedType.ByValTStr _
, SizeConst:=LF_FACESIZE)> _
Public lfFaceName As String
と書き直す事で正常に固定長文字列を定義することが出来ました。
次にYuOさんより指摘されたペナルティについてですが、
まさにこれが今回の指定したフォントが取得できないという
原因のようでした。
指定した論理フォントから物理フォントを選択する際に、
ペナルティ(重み)により評価を行うらしいのですが、
ここで、指定した論理フォントではなく代替フォントが
選択されてしまっていたようです。
フォントの選択についてこんな文書も見つけたので参考に。
http://www.y-adagio.com/public/committees/ipsj-ts_wg7/2008/wg7-07/07-04.doc
解決をつけわすれました＾＾；
| ツイート |  |