C# と VB.NET の質問掲示板

■No102508 (KOZ) に返信

面倒なら TabPage 実際の文字列は Tag プロパティに保存しておいて、Text プロパティはスペースで埋めておいて文字列のみ描画すればいいかも。

Public Class CustomTabControl
    Inherits TabControl

    Public Sub New()
        DoubleBuffered = True
        SetStyle(ControlStyles.UserPaint, False)
    End Sub

    Const WM_PAINT = &HF

    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 Else
                MyBase.WndProc(m)
        End Select
    End Sub

    Protected Overrides Sub OnPaint(e As PaintEventArgs)
        Dim hdc = e.Graphics.GetHdc()
        Dim m = Message.Create(Handle, WM_PAINT, hdc, IntPtr.Zero)
        DefWndProc(m)
        e.Graphics.ReleaseHdc()

        ' ここで文字を書く

        MyBase.OnPaint(e)
    End Sub
End Class

■No102514 (カルミーア さん) に返信

>>TabControlを自分でビジュアルスタイルで描画する
>>https://dobon.net/vb/dotnet/control/tabsidebug.html#paint
>>が参考になると思います。
> こちらせっかく御紹介頂き申し訳ないですが、面倒というよりも目的と剥離しているような気がしました。
> タブの回転などは全く不要で、必要な部分が何なのかがよくわからない状況です。

コピペして文字を描いているところだけ修正すればいいんですが・・・

> 加えてこちらのサンプルは色をべた塗しておりますが、私が求めるものはデフォルトと同じグレーのグラデーション色です。
> グレーのグラデーション色に設定しているものをご提示頂けると大変ありがたいです。

コピペして実行してみました？

>>面倒なら TabPage 実際の文字列は Tag プロパティに保存しておいて、Text プロパティはスペースで埋めておいて文字列のみ描画すればいいかも。
> ソースコードを提示してくださってありがとうございます。
> ただ、私の要求が正直こんなに手の込んだものになるとは思わず、かなり難航しています。
> ビットマップ形式のファイルが必要？みたいですが、そうなってくると開発陣や顧客に相談しないといけなくなります。

ファイルは不要です。耳の位置は上固定でいいなら簡単です。
TabPage の Tag プロパティに表示する文字、Text プロパティには相応の空白を設定してください。

Public Class CustomTabControl
    Inherits TabControl

    Public Sub New()
        DoubleBuffered = True
        ResizeRedraw = True
        SetStyle(ControlStyles.UserPaint, False)
    End Sub

    Const WM_PAINT = &HF

    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 Else
                MyBase.WndProc(m)
        End Select
    End Sub

    Protected Overrides Sub OnPaint(e As PaintEventArgs)
        Dim hdc = e.Graphics.GetHdc()
        Dim m = 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 needDispose As Boolean = False
            If i = SelectedIndex Then
                tabColor = Color.Red
                tabFont = New Font(Font.FontFamily, Font.Size, FontStyle.Bold)
                needDispose = True
            Else
                tabColor = ForeColor
                tabFont = Font
            End If
            TextRenderer.DrawText(e.Graphics, CStr(page.Tag),
                                  tabFont, rect, tabColor,
                                  TextFormatFlags.HorizontalCenter Or TextFormatFlags.VerticalCenter)
            If needDispose Then
                tabFont.Dispose()
            End If
        Next
        MyBase.OnPaint(e)
    End Sub

End Class

■No102597 (カルミーア さん) に返信

※ 弁士さんの報告を元に修正しています。

Tab プロパティ使わないバージョンを作ってみました。
テキストをセットする際、TCITEM.pszText を同等幅のスペースに置き換えます。
Image は考慮していませんので、使っている場合は描画位置を調整してください。

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

■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