1. Este site usa cookies. Ao continuar a usar este site está a concordar com o nosso uso de cookies. Saber Mais.

[VB9]Painel Ext com XP-Border Style e Gradient Color [Repositorio Codigo]

Discussão em 'Programação' iniciada por fLaSh_CF, 23 de Outubro de 2008. (Respostas: 0; Visualizações: 1403)

  1. fLaSh_CF

    fLaSh_CF Banido

    Boas;

    Acabei de criar um componente e aproveito posto aqui.
    O componente é um Painel que suporta as "Border Theme" do OS e também suporta Background Gradient!
    A implementação e feita por API e utiliza uma SubClass.

    Para instalar, criem um ficheiro com o nome (recomendado) "urcPainelExt.vb" e coloquem o seguinte código:
    Código:
    '************************************ 
    '  Copyright(C)fLaSh - Carlos.DF
    ' [email protected]
    '        10-21-2008
    '************************************
    Imports System
    Imports System.Drawing
    Imports System.Runtime.InteropServices
    Imports System.Windows.Forms
    Imports System.ComponentModel
    Public Class urcPainelExt
        Inherits System.Windows.Forms.Panel
    
    #Region "Component Designer generated code"
    
        <System.Diagnostics.DebuggerNonUserCode()> _
        Public Sub New(ByVal container As System.ComponentModel.IContainer)
            MyClass.New()
    
            'Required for Windows.Forms Class Composition Designer support
            If (container IsNot Nothing) Then
                container.Add(Me)
            End If
    
        End Sub
    
        <System.Diagnostics.DebuggerNonUserCode()> _
        Public Sub New()
            MyBase.New()
    
            'This call is required by the Component Designer.
            InitializeComponent()
    
        End Sub
    
        'Component overrides dispose to clean up the component list.
        <System.Diagnostics.DebuggerNonUserCode()> _
        Protected Overrides Sub Dispose(ByVal disposing As Boolean)
            Try
                If disposing AndAlso components IsNot Nothing Then
                    components.Dispose()
                End If
            Finally
                MyBase.Dispose(disposing)
            End Try
        End Sub
    
        'Required by the Component Designer
        Private components As System.ComponentModel.IContainer
    
        'NOTE: The following procedure is required by the Component Designer
        'It can be modified using the Component Designer.
        'Do not modify it using the code editor.
        <System.Diagnostics.DebuggerStepThrough()> _
        Private Sub InitializeComponent()
            components = New System.ComponentModel.Container()
            Me.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
            Me.AutoScroll = True
        End Sub
    
    #End Region
    
    #Region " Paint FX "
    
        Private __EnableBCGradient As Boolean = True
        Private __GradColor1 As Color = Color.AliceBlue
        Private __GradColor2 As Color = Color.LightSteelBlue
        Private __GradMode As Drawing2D.LinearGradientMode = Drawing2D.LinearGradientMode.ForwardDiagonal
     
        <Category("Appearance"), Description("Start Gradient Color")> _
        Public Property GradColor1() As Color
            Get
                Return Me.__GradColor1
            End Get
            Set(ByVal value As Color)
                Me.__GradColor1 = value
                Me.Invalidate()
            End Set
        End Property
    
        <Category("Appearance"), Description("End Gradient Color")> _
        Public Property GradColor2() As Color
            Get
                Return Me.__GradColor2
            End Get
            Set(ByVal value As Color)
                Me.__GradColor2 = value
                Me.Invalidate()
            End Set
        End Property
    
        <Category("Appearance"), Description("Gradient Mode")> _
        Public Property GradMode() As System.Drawing.Drawing2D.LinearGradientMode
            Get
                Return Me.__GradMode
            End Get
            Set(ByVal value As System.Drawing.Drawing2D.LinearGradientMode)
                Me.__GradMode = value
                Me.Invalidate()
            End Set
        End Property
    
        <Category("Behavior"), Description("Enables or Disables Background Gradient")> _
        Public Property EnableBCGradient() As Boolean
            Get
                Return Me.__EnableBCGradient
            End Get
            Set(ByVal value As Boolean)
                Me.__EnableBCGradient = value
                Me.Invalidate()
            End Set
        End Property
    
        Private Sub urcPainelExt_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
            MyBase.OnPaintBackground(e)
            If Me.__EnableBCGradient = False Then
                Return
            End If
            Dim rect As New Rectangle(0, 0, Me.Width, Me.Height)
            Dim lb As New System.Drawing.Drawing2D.LinearGradientBrush(rect, Me.__GradColor1, Me.__GradColor2, Me.__GradMode)
            e.Graphics.FillRectangle(lb, rect)
        End Sub
    
        Private Sub urcPainelExt_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Resize
            MyBase.Refresh()
        End Sub
    
    #End Region
    
    #Region " Border Style "
    
        ''' <summary>
        ''' Contains the size of the visual style borders
        ''' </summary>
        Private __BorderRect As NativeMethods.RECT
     
        Public Enum enBorderStyle As Short
            None = 0
            FixedSingle = 1
            Fixed3D = 2
            Flat = 3
        End Enum
    
        Private __BorderStyle As enBorderStyle
     
        <Category("Appearance"), Description("Select Border Style")> _
        Public Overloads Property BorderStyle() As enBorderStyle
            Get
                Return __BorderStyle
            End Get
            Set(ByVal value As enBorderStyle)
                __BorderStyle = value
                Me.Invalidate()
                Call UpDateVisualStyle()
            End Set
        End Property
    
        ''' <summary>
        ''' Filter some message we need to draw the border.
        ''' </summary>
        Protected Overloads Overrides Sub WndProc(ByRef m As Message)
            If RenderWithVisualStyles() Then
                Select Case m.Msg
                    Case NativeMethods.WM_NCPAINT
                        ' the border painting is done here.
                        WmNcPaint(m)
                        Exit Select
                    Case NativeMethods.WM_NCCALCSIZE
                        ' the size of the client area is calcuated here.
                        WmNcCalcSize(m)
                        Exit Select
                    Case NativeMethods.WM_THEMECHANGED
                        ' Updates styles when the theme is changing.
                        UpdateStyles()
                        Exit Select
                    Case Else
                        MyBase.WndProc(m)
                        Exit Select
                End Select
            Else
                MyBase.WndProc(m)
                Return
            End If
        End Sub
    
        ''' <summary>
        ''' Calculates the size of the window frame and client area of the Painel
        ''' </summary>
        Private Sub WmNcCalcSize(ByRef m As Message)
    
            ' let the control draw the scrollbar if necessary.
            MyBase.WndProc(m)
    
            ' we visual styles are not enabled and BorderStyle is not Fixed3D then we have nothing more to do.
            If Not Me.RenderWithVisualStyles() Then
                Return
            End If
    
            ' contains detailed information about WM_NCCALCSIZE message
            Dim oParams As New NativeMethods.NCCALCSIZE_PARAMS()
    
            ' contains the window frame RECT
            Dim oRect As NativeMethods.RECT
    
            'If m.WParam = IntPtr.Zero Then
            ' LParam points to a RECT struct
            oRect = DirectCast(Marshal.PtrToStructure(m.LParam, GetType(NativeMethods.RECT)), NativeMethods.RECT)
    
            ' contains the client area of the control
            Dim curRect As NativeMethods.RECT
    
            ' get the DC
            Dim hDC As IntPtr = NativeMethods.GetWindowDC(Me.Handle)
    
            ' open theme data
            Dim hTheme As IntPtr = NativeMethods.OpenThemeData(Me.Handle, "EDIT")
    
            ' find out how much space the borders needs
            If NativeMethods.GetThemeBackgroundContentRect(hTheme, hDC, NativeMethods.ETS_NORMAL, NativeMethods.ETS_NORMAL, oRect, curRect) = NativeMethods.S_OK Then
                ' shrink the client area the make more space for containing text.
                curRect.Inflate(-1, -1)
    
                ' remember the space of the borders
                Me.__BorderRect = New NativeMethods.RECT(curRect.Left - oRect.Left, curRect.Top - oRect.Top, oRect.Right - curRect.Right, oRect.Bottom - curRect.Bottom)
    
                ' update LParam of the message with the new client area
                If m.WParam = IntPtr.Zero Then
                    Marshal.StructureToPtr(curRect, m.LParam, False)
                Else
                    oParams.rgrc0 = curRect
                    Marshal.StructureToPtr(oParams, m.LParam, False)
                End If
    
                ' force the control to redraw it´s client area
                m.Result = New IntPtr(NativeMethods.WVR_REDRAW)
            End If
    
            ' release theme data handle
            NativeMethods.CloseThemeData(hTheme)
    
            ' release DC
            NativeMethods.ReleaseDC(Me.Handle, hDC)
        End Sub
    
        ''' <summary>
        ''' The border painting is done here.
        ''' </summary>
        Private Sub WmNcPaint(ByRef m As Message)
            MyBase.WndProc(m)
    
            If Not Me.RenderWithVisualStyles() Then
                Return
            End If
    
            '**************************************************************************
            ' Get the DC of the window frame and paint the border using uxTheme API´s
            '**************************************************************************
    
            ' set the part id to Painel
            Dim partId As Integer = NativeMethods.ETS_NORMAL
    
            ' set the state id of the current Painel
            Dim stateId As Integer
            If Me.Enabled Then
                If Me.Enabled = False Then
                    stateId = NativeMethods.ETS_READONLY
                Else
                    stateId = NativeMethods.ETS_NORMAL
                End If
            Else
                stateId = NativeMethods.ETS_DISABLED
            End If
    
            ' define the windows frame rectangle of the Painel
            Dim windowRect As NativeMethods.RECT
            NativeMethods.GetWindowRect(Me.Handle, windowRect)
            windowRect.Right -= windowRect.Left
            windowRect.Bottom -= windowRect.Top
            windowRect.Top = InlineAssignHelper(windowRect.Left, 0)
    
            ' get the device context of the window frame
            Dim hDC As IntPtr = NativeMethods.GetWindowDC(Me.Handle)
    
            ' define a rectangle inside the borders and exclude it from the DC
            Dim clientRect As NativeMethods.RECT = windowRect
            clientRect.Left += Me.__BorderRect.Left
            clientRect.Top += Me.__BorderRect.Top
            clientRect.Right -= Me.__BorderRect.Right
            clientRect.Bottom -= Me.__BorderRect.Bottom
            NativeMethods.ExcludeClipRect(hDC, clientRect.Left, clientRect.Top, clientRect.Right, clientRect.Bottom)
    
            ' open theme data
            Dim hTheme As IntPtr = NativeMethods.OpenThemeData(Me.Handle, "EDIT")
    
            ' make sure the background is updated when transparent background is used.
            If NativeMethods.IsThemeBackgroundPartiallyTransparent(hTheme, NativeMethods.ETS_NORMAL, NativeMethods.ETS_NORMAL) <> 0 Then
                NativeMethods.DrawThemeParentBackground(Me.Handle, hDC, windowRect)
            End If
    
            ' draw background
            NativeMethods.DrawThemeBackground(hTheme, hDC, partId, stateId, windowRect, IntPtr.Zero)
    
            ' close theme data
            NativeMethods.CloseThemeData(hTheme)
    
            ' release dc
            NativeMethods.ReleaseDC(Me.Handle, hDC)
    
            ' we have processed the message so set the result to zero
            m.Result = IntPtr.Zero
        End Sub
    
        ''' <summary>
        ''' Returns true, when visual styles are enabled in this application.
        ''' </summary>
        Private Function VisualStylesEnabled() As Boolean
            ' Check if RenderWithVisualStyles property is available in the Application class (New feature in NET 2.0)
            Dim t As Type = GetType(Application)
            Dim pi As System.Reflection.PropertyInfo = t.GetProperty("RenderWithVisualStyles")
    
            If pi Is Nothing Then
                ' NET 1.1
                Dim os As OperatingSystem = System.Environment.OSVersion
                If os.Platform = PlatformID.Win32NT AndAlso (((os.Version.Major = 5) AndAlso (os.Version.Minor >= 1)) OrElse (os.Version.Major > 5)) Then
                    Dim version As New NativeMethods.DLLVersionInfo()
                    version.cbSize = Marshal.SizeOf(GetType(NativeMethods.DLLVersionInfo))
                    If NativeMethods.DllGetVersion(version) = 0 Then
                        Return (version.dwMajorVersion > 5) AndAlso NativeMethods.IsThemeActive() AndAlso NativeMethods.IsAppThemed()
                    End If
                End If
    
                Return False
            Else
                ' NET 2.0
                Dim result As Boolean = CBool(pi.GetValue(Nothing, Nothing))
                Return result
            End If
        End Function
    
        ''' <summary>
        ''' Return true, when this control should render with visual styles.
        ''' </summary>
        ''' <returns></returns>
        Private Function RenderWithVisualStyles() As Boolean
            Return CBool(__BorderStyle = enBorderStyle.Fixed3D AndAlso Me.VisualStylesEnabled)
        End Function
    
        ''' <summary>
        ''' Update the control parameters.
        ''' </summary>
        Protected Overloads Overrides ReadOnly Property CreateParams() As CreateParams
            Get
                Dim p As CreateParams = MyBase.CreateParams
    
                ' remove the Fixed3D border style
                If Me.RenderWithVisualStyles() AndAlso (p.ExStyle And NativeMethods.WS_EX_CLIENTEDGE) = NativeMethods.WS_EX_CLIENTEDGE Then
                    p.ExStyle = p.ExStyle Xor NativeMethods.WS_EX_CLIENTEDGE
                End If
    
                Return p
            End Get
        End Property
        Private Shared Function InlineAssignHelper(Of T)(ByRef target As T, ByVal value As T) As T
            target = value
            Return value
        End Function
    
        ''' <summary>
        ''' Update the control visual style.
        ''' </summary>
        ''' <remarks></remarks>
        Private Sub UpDateVisualStyle()
            Select Case __BorderStyle
                Case enBorderStyle.None
                    MyBase.BorderStyle = Windows.Forms.BorderStyle.FixedSingle
                    Me.Refresh()
                    MyBase.BorderStyle = Windows.Forms.BorderStyle.None
                Case enBorderStyle.FixedSingle
                    MyBase.BorderStyle = Windows.Forms.BorderStyle.FixedSingle
                Case enBorderStyle.Fixed3D
                    MyBase.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
                Case enBorderStyle.Flat
                    MyBase.BorderStyle = Windows.Forms.BorderStyle.None
                    MakeFlatBorder(MyBase.Handle.ToInt32)
            End Select
            MyBase.Refresh()
        End Sub
    
    #End Region
    
    End Class
    
    Friend NotInheritable Class NativeMethods
        Shared Sub New()
        End Sub
    
        ' API´s to get device context of the window frame
        <DllImport("user32.dll")> _
        Public Shared Function GetWindowDC(ByVal hWnd As IntPtr) As IntPtr
        End Function
        <DllImport("user32.dll")> _
        Public Shared Function ReleaseDC(ByVal hWnd As IntPtr, ByVal hDC As IntPtr) As Integer
        End Function
        <DllImport("user32.dll")> _
        Public Shared Function GetWindowRect(ByVal hWnd As IntPtr, ByRef lpRect As RECT) As Boolean
        End Function
        <DllImport("gdi32.dll")> _
        Public Shared Function ExcludeClipRect(ByVal hdc As IntPtr, ByVal nLeftRect As Integer, ByVal nTopRect As Integer, ByVal nRightRect As Integer, ByVal nBottomRect As Integer) As Integer
        End Function
    
        ' API´s for xp visual styles 
        <StructLayout(LayoutKind.Sequential)> _
        Public Structure DLLVersionInfo
            Public cbSize As Integer
            Public dwMajorVersion As Integer
            Public dwMinorVersion As Integer
            Public dwBuildNumber As Integer
            Public dwPlatformID As Integer
        End Structure
        <DllImport("UxTheme.dll", CharSet:=CharSet.Auto)> _
        Public Shared Function IsAppThemed() As Boolean
        End Function
        <DllImport("UxTheme.dll", CharSet:=CharSet.Auto)> _
        Public Shared Function IsThemeActive() As Boolean
        End Function
        <DllImport("comctl32.dll", CharSet:=CharSet.Auto)> _
        Public Shared Function DllGetVersion(ByRef version As DLLVersionInfo) As Integer
        End Function
        <DllImport("uxtheme.dll", ExactSpelling:=True, CharSet:=CharSet.Unicode)> _
        Public Shared Function OpenThemeData(ByVal hWnd As IntPtr, ByVal classList As String) As IntPtr
        End Function
        <DllImport("uxtheme.dll", ExactSpelling:=True)> _
        Public Shared Function CloseThemeData(ByVal hTheme As IntPtr) As Int32
        End Function
        <DllImport("uxtheme", ExactSpelling:=True)> _
        Public Shared Function DrawThemeBackground(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByRef pRect As RECT, ByVal pClipRect As IntPtr) As Int32
        End Function
        <DllImport("uxtheme", ExactSpelling:=True)> _
        Public Shared Function IsThemeBackgroundPartiallyTransparent(ByVal hTheme As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer) As Integer
        End Function
        <DllImport("uxtheme", ExactSpelling:=True)> _
        Public Shared Function GetThemeBackgroundContentRect(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByRef pBoundingRect As RECT, ByRef pContentRect As RECT) As Int32
        End Function
        <DllImport("uxtheme", ExactSpelling:=True)> _
        Public Shared Function DrawThemeParentBackground(ByVal hWnd As IntPtr, ByVal hdc As IntPtr, ByRef pRect As RECT) As Int32
        End Function
        <DllImport("uxtheme", ExactSpelling:=True)> _
        Public Shared Function DrawThemeBackground(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByRef pRect As RECT, ByRef pClipRect As RECT) As Int32
        End Function
    
        Public Const S_OK As Integer = &H0
    
        Public Const ETS_DISABLED As Integer = 4
        Public Const ETS_NORMAL As Integer = 1
        Public Const ETS_READONLY As Integer = 6
    
        Public Const WM_THEMECHANGED As Integer = &H31A
        Public Const WM_NCPAINT As Integer = &H85
        Public Const WM_NCCALCSIZE As Integer = &H83
    
        Public Const WS_EX_CLIENTEDGE As Integer = &H200
        Public Const WVR_HREDRAW As Integer = &H100
        Public Const WVR_VREDRAW As Integer = &H200
        Public Const WVR_REDRAW As Integer = (WVR_HREDRAW Or WVR_VREDRAW)
    
        <StructLayout(LayoutKind.Sequential)> _
        Public Structure NCCALCSIZE_PARAMS
            Public rgrc0 As RECT, rgrc1 As RECT, rgrc2 As RECT
            Public lppos As IntPtr
        End Structure
    
        <Serializable(), StructLayout(LayoutKind.Sequential)> _
        Public Structure RECT
            Public Left As Integer
            Public Top As Integer
            Public Right As Integer
            Public Bottom As Integer
            Public Sub New(ByVal left_ As Integer, ByVal top_ As Integer, ByVal right_ As Integer, ByVal bottom_ As Integer)
                Left = left_
                Top = top_
                Right = right_
                Bottom = bottom_
            End Sub
            Public ReadOnly Property Height() As Integer
                Get
                    Return Bottom - Top + 1
                End Get
            End Property
            Public ReadOnly Property Width() As Integer
                Get
                    Return Right - Left + 1
                End Get
            End Property
            Public ReadOnly Property Size() As Size
                Get
                    Return New Size(Width, Height)
                End Get
            End Property
            Public ReadOnly Property Location() As Point
                Get
                    Return New Point(Left, Top)
                End Get
            End Property
            ' Handy method for converting to a System.Drawing.Rectangle
            Public Function ToRectangle() As Rectangle
                Return Rectangle.FromLTRB(Left, Top, Right, Bottom)
            End Function
            Public Shared Function FromRectangle(ByVal rectangle As Rectangle) As RECT
                Return New RECT(rectangle.Left, rectangle.Top, rectangle.Right, rectangle.Bottom)
            End Function
            Public Sub Inflate(ByVal width As Integer, ByVal height As Integer)
                Me.Left -= width
                Me.Top -= height
                Me.Right += width
                Me.Bottom += height
            End Sub
            Public Overloads Overrides Function GetHashCode() As Integer
                Return Left Xor ((Top << 13) Or (Top >> &H13)) Xor ((Width << &H1A) Or (Width >> 6)) Xor ((Height << 7) Or (Height >> &H19))
            End Function
    #Region "Operator overloads"
            Public Shared Widening Operator CType(ByVal rect As RECT) As Rectangle
                Return Rectangle.FromLTRB(rect.Left, rect.Top, rect.Right, rect.Bottom)
            End Operator
    
            Public Shared Widening Operator CType(ByVal rect As Rectangle) As RECT
                Return New RECT(rect.Left, rect.Top, rect.Right, rect.Bottom)
            End Operator
    #End Region
        End Structure
    End Class
     
    Tambem poderão fazer o download do project sample em: http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=6883&lngWId=10
    PS: o código aqui postado está mais recente do que o do link, fixei alguns pequenos bugs.

    Compr.
     
    Última edição: 23 de Outubro de 2008

Partilhar esta Página