|
ちょっと書いてみました。250行くらいです。
Imports System.Text
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Public Class PaddingTextBox
Inherits TextBox
Public Sub New()
MyBase.AutoSize = False
SetStyle(ControlStyles.FixedHeight, True)
End Sub
<Browsable(True)>
<EditorBrowsable(EditorBrowsableState.Always)>
<DesignerSerializationVisibility(DesignerSerializationVisibility.Visible)>
Public Shadows Property Padding As Padding
Get
Return MyBase.Padding
End Get
Set(value As Padding)
MyBase.Padding = value
End Set
End Property
Protected Overrides ReadOnly Property CreateParams As CreateParams
Get
Dim cp As CreateParams = MyBase.CreateParams
cp.Style = cp.Style Or ES_MULTILINE
Return cp
End Get
End Property
Private _AutoSize As Boolean = True
Public Overrides Property AutoSize As Boolean
Get
Return _AutoSize
End Get
Set(value As Boolean)
If AutoSize <> value Then
_AutoSize = value
SetStyle(ControlStyles.FixedHeight, value)
OnAutoSizeChanged(EventArgs.Empty)
End If
End Set
End Property
Protected Overrides Sub OnHandleCreated(e As EventArgs)
MyBase.OnHandleCreated(e)
DoLayout()
End Sub
Protected Overrides Sub OnPaddingChanged(e As EventArgs)
MyBase.OnPaddingChanged(e)
DoLayout()
End Sub
Protected Overrides Sub OnFontChanged(e As EventArgs)
MyBase.OnFontChanged(e)
DoLayout()
End Sub
Private Sub DoLayout()
AdjustHeight()
Dim r As Rectangle = ClientRectangle
r = DeflateRect(r, Padding)
Dim rect As New RECT(r)
SendMessage(Handle, EM_SETRECT, IntPtr.Zero, rect)
End Sub
Private Sub AdjustHeight()
If Not AutoSize Or Multiline Then Return
FontHeight = Font.Height
Dim hdc As IntPtr = CreateCompatibleDC(IntPtr.Zero)
Dim hFont As IntPtr = Font.ToHfont()
Dim oldFont As IntPtr = SelectObject(hdc, hFont)
Try
Dim tm As New TEXTMETRICW()
GetTextMetricsW(hdc, tm)
Dim cs As Size = ClientSize
cs.Height = tm.tmHeight + Padding.Top + Padding.Bottom
ClientSize = cs
Finally
SelectObject(hdc, oldFont)
DeleteObject(hFont)
DeleteDC(hdc)
End Try
End Sub
Private Shared Function DeflateRect(rect As Rectangle, padd As Padding) As Rectangle
rect.X += padd.Left
rect.Y += padd.Top
rect.Width -= padd.Horizontal
rect.Height -= padd.Vertical
Return rect
End Function
Protected Overrides Sub OnResize(e As EventArgs)
MyBase.OnResize(e)
DoLayout()
End Sub
Protected Overrides Sub OnKeyPress(e As KeyPressEventArgs)
If Not Multiline Then
Select Case e.KeyChar
Case CHAR_CR, CHAR_LF, CHAR_TAB
e.Handled = True
Return
End Select
End If
MyBase.OnKeyPress(e)
End Sub
Private Function RemoveControlChar(value As String) As String
Dim sb As New StringBuilder(value.Length)
For Each c As Char In value
Select Case c
Case CHAR_CR, CHAR_LF, CHAR_TAB
Case Else
sb.Append(c)
End Select
Next
Return sb.ToString()
End Function
Protected Overrides Sub WndProc(ByRef m As Message)
If Multiline Then
MyBase.WndProc(m)
Else
Select Case m.Msg
Case WM_SETTEXT, EM_REPLACESEL
Dim setText As String = Marshal.PtrToStringUni(m.LParam)
setText = RemoveControlChar(setText)
Dim ptr As IntPtr = Marshal.StringToCoTaskMemAuto(setText)
Try
Dim msg As Message = Message.Create(m.HWnd, m.Msg, m.WParam, ptr)
MyBase.WndProc(msg)
Finally
Marshal.FreeCoTaskMem(ptr)
End Try
Case WM_PASTE
If Clipboard.ContainsText() Then
Dim pasteText As String = RemoveControlChar(Clipboard.GetText())
Dim ptr As IntPtr = Marshal.StringToCoTaskMemAuto(pasteText)
Try
Dim msg As Message = Message.Create(m.HWnd, EM_REPLACESEL, New IntPtr(1), ptr)
MyBase.WndProc(msg)
Finally
Marshal.FreeCoTaskMem(ptr)
End Try
End If
Case Else
MyBase.WndProc(m)
End Select
End If
End Sub
Private Const CHAR_CR As Char = ChrW(&HD)
Private Const CHAR_LF As Char = ChrW(&HA)
Private Const CHAR_TAB As Char = ChrW(&H9)
Private Const WM_SETTEXT As Integer = &HC
Private Const WM_PASTE As Integer = &H302
Private Const EM_SETRECT As Integer = &HB3
Private Const EM_REPLACESEL As Integer = &HC2
Private Const ES_MULTILINE As Integer = &H4
<DllImport("Gdi32")>
Private Shared Function CreateCompatibleDC(hDC As IntPtr) As IntPtr
End Function
<DllImport("User32")>
Private Shared Function GetDC(hWnd As IntPtr) As IntPtr
End Function
<DllImport("User32")>
Private Shared Function ReleaseDC(hWnd As IntPtr, hDC As IntPtr) As Boolean
End Function
<DllImport("Gdi32")>
Public Shared Function DeleteDC(hdc As IntPtr) As Boolean
End Function
<DllImport("Gdi32")>
Public Shared Function SelectObject(hdc As IntPtr, hgdiobj As IntPtr) As IntPtr
End Function
<DllImport("Gdi32")>
Public Shared Function DeleteObject(hObject As IntPtr) As Boolean
End Function
<StructLayout(LayoutKind.Sequential)>
Private Structure TEXTMETRICW
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 UShort
Public tmLastChar As UShort
Public tmDefaultChar As UShort
Public tmBreakChar As UShort
Public tmItalic As Byte
Public tmUnderlined As Byte
Public tmStruckOut As Byte
Public tmPitchAndFamily As Byte
Public tmCharSet As Byte
End Structure
<StructLayout(LayoutKind.Sequential)>
Private Structure RECT
Public Left As Integer, Top As Integer, Right As Integer, Bottom As Integer
Public Sub New(r As Rectangle)
Left = r.Left : Top = r.Top : Right = r.Right : Bottom = r.Bottom
End Sub
Public Function ToRectangle() As Rectangle
Return Rectangle.FromLTRB(Left, Top, Right, Bottom)
End Function
End Structure
<DllImport("Gdi32")>
Private Shared Function GetTextMetricsW(hdc As IntPtr, ByRef lptm As TEXTMETRICW) As Boolean
End Function
<DllImport("User32", CharSet:=CharSet.Auto)>
Private Shared Function SendMessage(hwnd As IntPtr, wMsg As Integer, wParam As IntPtr, lParam As IntPtr) As IntPtr
End Function
<DllImport("User32", CharSet:=CharSet.Auto)>
Private Shared Function SendMessage(hwnd As IntPtr, wMsg As Integer, wParam As IntPtr, ByRef lParam As RECT) As IntPtr
End Function
End Class
|