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:
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.
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
PS: o código aqui postado está mais recente do que o do link, fixei alguns pequenos bugs.
Compr.
Última edição: