Public Const LF_FACESIZE As Int32 = 32 Public Const DEFAULT_CHARSET As Byte = 1 Public Const FW_NORMAL As Int32 = 400 Public Const FIXED_PITCH As Byte = 1 Public Const OUT_RASTER_PRECIS As Byte = 6 Public Const WM_SETFONT As Int32 = &H30
<StructLayout(LayoutKind.Sequential)> _ Public Structure LOGFONT Public lfHeight As Int32 Public lfWidth As Int32 Public lfEscapement As Int32 Public lfOrientation As Int32 Public lfWeight As Int32 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 Public Sub New(ByVal fontName As String) lfWeight = FW_NORMAL lfCharSet = DEFAULT_CHARSET lfPitchAndFamily = FIXED_PITCH lfOutPrecision = OUT_RASTER_PRECIS lfFaceName = fontName lfHeight = 32 End Sub End Structure
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As Int32 Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As Int32, ByVal wParam As Int32, ByVal lParam As Int32) As Integer
'Private Shared mLF As New LOGFONT("FixedSys") Private Shared mLF As New LOGFONT("Impact")
Private Shared hFixedSys As Int32
Public Shared Sub SetFont(ByVal hWnd As IntPtr) hFixedSys = CreateFontIndirect(mLF) SendMessage(hWnd, WM_SETFONT, hFixedSys, 1) End Sub Protected Overrides Sub Finalize() MyBase.Finalize() If hFixedSys <> 0 Then DeleteObject(hFixedSys) End If End Sub End Class
'フォームロード時にテキストボックスのフォントを指定フォントにする Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
分類:[.NET]
フォームのテキストボックス(TextBox1)の文字を指定したフォントで表示させたいと思っています。指定するフォントはデザイン画面のFONTプロパティのフォント名リストにないフォントです。(文字ベンダー作の外字を含む特殊フォント)
SendMessageであればどんなフォントでも表示可能と聞いたもんで…。以下のコードではうまくいきません。追加する部分があるのでしょうか?
Public Class useFixedSys
Public Const LF_FACESIZE As Int32 = 32
Public Const DEFAULT_CHARSET As Byte = 1
Public Const FW_NORMAL As Int32 = 400
Public Const FIXED_PITCH As Byte = 1
Public Const OUT_RASTER_PRECIS As Byte = 6
Public Const WM_SETFONT As Int32 = &H30
<StructLayout(LayoutKind.Sequential)> _
Public Structure LOGFONT
Public lfHeight As Int32
Public lfWidth As Int32
Public lfEscapement As Int32
Public lfOrientation As Int32
Public lfWeight As Int32
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
Public Sub New(ByVal fontName As String)
lfWeight = FW_NORMAL
lfCharSet = DEFAULT_CHARSET
lfPitchAndFamily = FIXED_PITCH
lfOutPrecision = OUT_RASTER_PRECIS
lfFaceName = fontName
lfHeight = 32
End Sub
End Structure
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As Int32
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As Int32, ByVal wParam As Int32, ByVal lParam As Int32) As Integer
'Private Shared mLF As New LOGFONT("FixedSys")
Private Shared mLF As New LOGFONT("Impact")
Private Shared hFixedSys As Int32
Public Shared Sub SetFont(ByVal hWnd As IntPtr)
hFixedSys = CreateFontIndirect(mLF)
SendMessage(hWnd, WM_SETFONT, hFixedSys, 1)
End Sub
Protected Overrides Sub Finalize()
MyBase.Finalize()
If hFixedSys <> 0 Then
DeleteObject(hFixedSys)
End If
End Sub
End Class
'フォームロード時にテキストボックスのフォントを指定フォントにする
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
useFixedSys.SetFont(TextBox1.Handle)
TextBox1.AppendText("ABCDEFGH")
end Sub