|
■No102607 (KOZ) に返信
最終バージョン?
Option Strict On
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Public Class CustomTabControl
Inherits TabControl
<DesignerSerializationVisibility(DesignerSerializationVisibility.Content)>
Public ReadOnly Property ColoredTabs As New List(Of Integer)()
Public Sub New()
DoubleBuffered = True
ResizeRedraw = True
SetStyle(ControlStyles.UserPaint, False)
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
Select Case m.Msg
Case WM_PAINT
SetStyle(ControlStyles.UserPaint, True)
MyBase.WndProc(m)
SetStyle(ControlStyles.UserPaint, False)
Case TCM_SETITEMA, TCM_SETITEMW
ReplaceTcItem(m)
Case TCM_INSERTITEMA, TCM_INSERTITEMW
ReplaceTcItem(m)
Case Else
MyBase.WndProc(m)
End Select
End Sub
Private Sub ReplaceTcItem(ByRef m As Message)
Dim item As TCITEM = Marshal.PtrToStructure(Of TCITEM)(m.LParam)
Dim pszText As String = Marshal.PtrToStringAuto(item.pszText)
Dim adSpace As String = AdjustSpace(pszText)
item.pszText = Marshal.StringToCoTaskMemAuto(adSpace)
item.cchTextMax = adSpace.Length
Dim lParam As IntPtr = Marshal.AllocCoTaskMem(Marshal.SizeOf(item))
Try
Marshal.StructureToPtr(item, lParam, False)
Dim newMessage As Message = Message.Create(m.HWnd, m.Msg, m.WParam, lParam)
MyBase.WndProc(newMessage)
m.Result = newMessage.Result
Finally
Marshal.FreeCoTaskMem(item.pszText)
Marshal.FreeCoTaskMem(lParam)
End Try
End Sub
Private Function AdjustSpace(pszText As String) As String
Using g As Graphics = CreateGraphics()
Dim nLen As Integer = pszText.Length
Dim nWidth As Integer = TextRenderer.MeasureText(pszText, Font).Width
Do
Dim tmpStr As New String(" "c, nLen)
If TextRenderer.MeasureText(tmpStr, Font).Width >= nWidth Then
Return New String(" "c, nLen + 1)
End If
nLen += 1
Loop
End Using
End Function
Protected Overrides Sub OnPaint(e As PaintEventArgs)
Dim hdc As IntPtr = e.Graphics.GetHdc()
Dim m As Message = Message.Create(Handle, WM_PAINT, hdc, IntPtr.Zero)
DefWndProc(m)
e.Graphics.ReleaseHdc()
For i As Integer = 0 To TabPages.Count - 1
Dim page As TabPage = TabPages(i)
Dim rect As Rectangle = GetTabRect(i)
Dim tabColor As Color
Dim tabFont As Font
Dim flags As TextFormatFlags = TextFormatFlags.HorizontalCenter Or TextFormatFlags.VerticalCenter
Dim needDispose As Boolean = False
If ColoredTabs.Contains(i) Then
tabColor = Color.Red
tabFont = New Font(Font.FontFamily, Font.Size, FontStyle.Bold)
needDispose = True
Else
tabColor = ForeColor
tabFont = Font
End If
If i = SelectedIndex Then
rect.Y -= 1
Else
rect.Y += 1
End If
TextRenderer.DrawText(e.Graphics, page.Text,
tabFont, rect, tabColor, flags)
If needDispose Then
tabFont.Dispose()
End If
Next
MyBase.OnPaint(e)
End Sub
Private Const WM_PAINT As Integer = &HF
Private Const TCM_FIRST As Integer = &H1300
Private Const TCM_SETITEMA As Integer = TCM_FIRST + 6
Private Const TCM_SETITEMW As Integer = TCM_FIRST + 61
Private Const TCM_INSERTITEMA As Integer = TCM_FIRST + 7
Private Const TCM_INSERTITEMW As Integer = TCM_FIRST + 62
<StructLayout(LayoutKind.Sequential)>
Private Structure TCITEM
Public mask As Integer
Public dwState As Integer
Public dwStateMask As Integer
Public pszText As IntPtr
Public cchTextMax As Integer
Public iImage As Integer
Public lParam As IntPtr
End Structure
End Class
|