CustomTabControl.vb

CustomTabControl.vb

Option Strict On
Imports System.Runtime.InteropServices

Public Class CustomTabControl
    Inherits TabControl

    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 adSpace As String = AdjustSpace(item.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.DefWndProc(newMessage)
            m.Result = newMessage.Result
        Finally
            Marshal.FreeCoTaskMem(item.pszText)
            Marshal.FreeCoTaskMem(lParam)
        End Try
    End Sub

    Private Function AdjustSpace(pszText As IntPtr) As String
        Using g As Graphics = CreateGraphics()
            Dim prevText As String = Marshal.PtrToStringAuto(pszText)
            Dim nLen As Integer = prevText.Length
            Dim nWidth As Integer = TextRenderer.MeasureText(prevText, 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 i = SelectedIndex Then
                tabColor = Color.Red
                tabFont = New Font(Font.FontFamily, Font.Size, FontStyle.Bold)
                needDispose = True
                rect.Y -= 1
            Else
                tabColor = ForeColor
                tabFont = Font
                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