Button List Bar.NET (159K)
23 Jan 2004
Corrected resource leak in drawing code. The hFont being returned by the ToHfont method was not being cleared up using DeleteObject.
vbAccelerator - Contents of code file: ButtonListBar_ButtonListBarTest_ButtonListBar.vb
Namespace vbAccelerator.Controls.ListBar
#Region " Event Argument Classes "
Public Class SelectionChangedEventArgs
Private m_item As ButtonListBarItem = Nothing
<System.ComponentModel.Description("Gets the item that selection has
changed to")> _
Public ReadOnly Property Item() As ButtonListBarItem
Get
Item = m_item
End Get
End Property
<System.ComponentModel.Description("Creates a new instance of the
SelectionChangedEventArgs class for the specified item")> _
Public Sub New(ByVal item As ButtonListBarItem)
m_item = item
End Sub
End Class
Public Class ItemClickEventArgs
Private m_item As ButtonListBarItem = Nothing
Private m_ptClick As Point
Private m_button As MouseButtons
<System.ComponentModel.Description("Gets the item that selection has
changed to")> _
Public ReadOnly Property Item() As ButtonListBarItem
Get
Item = m_item
End Get
End Property
<System.ComponentModel.Description("Gets the X position of the mouse if
the item click was done using the Mouse. If the click was done using
keys, this property is 0. Check MouseButton parameter to see if it
was a mouse event.")> _
Public ReadOnly Property X() As Integer
Get
X = m_ptClick.X
End Get
End Property
<System.ComponentModel.Description("Gets the Y position of the mouse if
the item click was done using the Mouse. If the click was done using
keys, this property is 0. Check MouseButton parameter to see if it
was a mouse event.")> _
Public ReadOnly Property Y() As Integer
Get
Y = m_ptClick.Y
End Get
End Property
<System.ComponentModel.Description("Gets the mouse button used to
perform the item click if it was done using the Mouse. If the click
was done using keys, the button will be set to None.")> _
Public ReadOnly Property Button() As MouseButtons
Get
Button = m_button
End Get
End Property
<System.ComponentModel.Description("Creates a new instance of the
ItemClickEventArgs class")> _
Public Sub New(ByVal item As ButtonListBarItem, ByVal ptClick As Point,
ByVal button As MouseButtons)
m_ptClick = ptClick
m_item = item
m_button = button
End Sub
End Class
#End Region
#Region " Delegates "
Public Delegate Sub ItemClickEventHandler(ByVal sender As Object, ByVal
eventArgs As ItemClickEventArgs)
Public Delegate Sub SelectionChangedEventHandler(ByVal sender As Object,
ByVal eventArgs As SelectionChangedEventArgs)
#End Region
#Region " ButtonListBar "
Public Class ButtonListBar
Inherits System.Windows.Forms.UserControl
#Region " Private Member Variables "
Private m_imageList As ImageList = Nothing
Private m_toolTip As ToolTip = Nothing
Private m_items As ButtonListBarItems = Nothing
Private m_isXp As Boolean = False
Private m_buttonWidth As Integer = 96
Private m_lastButtonWidth As Integer
Private m_showScroll As Boolean = False
#End Region
#Region " Events "
Public Event ItemClick As ItemClickEventHandler
Public Event BarClick As MouseEventHandler
Public Event SelectionChanged As SelectionChangedEventHandler
#End Region
#Region " Windows Form Designer generated code "
Public Sub New()
MyBase.New()
'This call is required by the Windows Form Designer.
InitializeComponent()
'Add any initialization after the InitializeComponent() call
End Sub
'UserControl overrides dispose to clean up the component list.
Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
If disposing Then
If Not (components Is Nothing) Then
components.Dispose()
End If
End If
MyBase.Dispose(disposing)
End Sub
'Required by the Windows Form Designer
Private components As System.ComponentModel.IContainer
'NOTE: The following procedure is required by the Windows Form Designer
'It can be modified using the Windows Form Designer.
'Do not modify it using the code editor.
<System.Diagnostics.DebuggerStepThrough()> Private Sub
InitializeComponent()
'
'ButtonListBar
'
Me.AutoScroll = True
Me.Name = "ButtonListBar"
End Sub
#End Region
#Region " UnManaged Code "
<System.Runtime.InteropServices.StructLayout(Runtime.InteropServices.Lay
outKind.Sequential)> _
Private Structure RECT
Public left As Integer
Public top As Integer
Public right As Integer
Public bottom As Integer
Public Overrides Function ToString() As String
ToString = String.Format("({0},{1})-({2},{3})", left, top,
right, bottom)
End Function
End Structure
<System.Runtime.InteropServices.StructLayout(Runtime.InteropServices.Lay
outKind.Sequential)> _
Private Structure SIZEAPI
Public cx As Integer
Public cy As Integer
Public Overrides Function ToString() As String
ToString = String.Format("{0} x {1}", cx, cy)
End Function
End Structure
Private Declare Function SelectObject Lib "gdi32" ( _
ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As IntPtr) As Integer
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As
Integer) As Integer
Private Const SM_CXVSCROLL As Integer = 2
Private Declare Unicode Function OpenThemeData Lib "uxtheme.dll" _
(ByVal hwnd As IntPtr, ByVal pszClassList As String) As IntPtr
Private Declare Unicode Function CloseThemeData Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr) As Integer
Private Declare Unicode Function DrawThemeBackground Lib "uxtheme.dll" _
(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 Integer
Private Declare Unicode Function DrawThemeParentBackground Lib
"uxtheme.dll" _
(ByVal hwnd As IntPtr, ByVal hDC As IntPtr, _
ByRef prc As RECT) As Integer
Private Declare Unicode Function GetThemeBackgroundContentRect Lib
"uxtheme.dll" _
(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 Integer
Private Declare Unicode Function DrawThemeText Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr, ByVal hDC As IntPtr, _
ByVal iPartId As Integer, ByVal iStateId As Integer, _
ByVal pszText As String, ByVal iCharCount As Integer, _
ByVal dwTextFlag As Integer, ByVal dwTextFlags2 As Integer, _
ByRef pRect As RECT) As Integer
Private Declare Unicode Function DrawThemeIcon Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr, ByVal hDC As IntPtr, _
ByVal iPartId As Integer, ByVal iStateId As Integer, _
ByRef pRect As RECT, _
ByVal hIml As IntPtr, _
ByVal iImageIndex As Integer) As Integer
Private Declare Unicode Function GetThemePartSize Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr, ByVal hDC As IntPtr, _
ByVal iPartId As Integer, ByVal iStateId As Integer, _
ByRef prc As RECT, _
ByVal eSize As Integer, _
ByRef psz As SIZEAPI) As Integer
Private Declare Unicode Function GetThemeTextExtent Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr, ByVal hDC As IntPtr, _
ByVal iPartId As Integer, ByVal iStateId As Integer, _
ByVal pszText As String, ByVal iCharCount As Integer, _
ByVal dwTextFlags As Integer, _
ByRef pBoundingRect As RECT, _
ByRef pExtentRect As RECT) As Integer
Private Declare Unicode Function DrawThemeEdge Lib "uxtheme.dll" _
(ByVal hTheme As IntPtr, ByVal hDC As IntPtr, _
ByVal iPartId As Integer, ByVal iStateId As Integer, _
ByRef pDestRect As RECT, _
ByVal uEdge As Integer, ByVal uFlags As Integer, _
ByRef pContentRect As RECT) As Integer
Private Const S_OK = 0
Private Const HWND_DESKTOP = 0
' THEMESIZE
Private Const TS_MIN As Integer = 0 '// minimum size
Private Const TS_TRUE As Integer = 1 '// size without
stretching
Private Const TS_DRAW As Integer = 2 '// size that theme mgr
will use to draw part
' Button class
Private Const UXTHEMEBUTTONCLASS As String = "Button"
Private Const UXTHEMETOOLBARCLASS As String = "Toolbar"
' Button part
Private Const TP_BUTTON As Integer = 1
Private Const BP_PUSHBUTTON As Integer = 1
' Button states
Private Const TS_NORMAL As Integer = 1
Private Const TS_HOT As Integer = 2
Private Const TS_PRESSED As Integer = 3
Private Const TS_DISABLED As Integer = 4
Private Const TS_CHECKED As Integer = 5
Private Const TS_HOTCHECKED As Integer = 6
Private Const PBS_DISABLED As Integer = 4
' DrawTextFlags
Private Const DT_TOP As Integer = &H0
Private Const DT_LEFT As Integer = &H0
Private Const DT_CENTER As Integer = &H1
Private Const DT_RIGHT As Integer = &H2
Private Const DT_VCENTER As Integer = &H4
Private Const DT_BOTTOM As Integer = &H8
Private Const DT_WORDBREAK As Integer = &H10
Private Const DT_SINGLELINE As Integer = &H20
Private Const DT_EXPANDTABS As Integer = &H40
Private Const DT_TABSTOP As Integer = &H80
Private Const DT_NOCLIP As Integer = &H100
Private Const DT_EXTERNALLEADING As Integer = &H200
Private Const DT_CALCRECT As Integer = &H400
Private Const DT_NOPREFIX As Integer = &H800
Private Const DT_INTERNAL As Integer = &H1000
Private Const DT_EDITCONTROL As Integer = &H2000
Private Const DT_PATH_ELLIPSIS As Integer = &H4000
Private Const DT_END_ELLIPSIS As Integer = &H8000&
Private Const DT_MODIFYSTRING As Integer = &H10000
Private Const DT_RTLREADING As Integer = &H20000
Private Const DT_WORD_ELLIPSIS As Integer = &H40000
Private Const DT_NOFULLWIDTHCHARBREAK As Integer = &H80000
Private Const DT_HIDEPREFIX As Integer = &H100000
Private Const DT_PREFIXONLY As Integer = &H200000
' UxTheme DrawText Additional Flag
Private Const DTT_GRAYED As Integer = &H1 '// draw a
grayed-out string
#End Region
Private Sub ButtonListBar_Load(ByVal sender As System.Object, ByVal e
As System.EventArgs) Handles MyBase.Load
MyBase.TabStop = True
MyBase.SetStyle( _
ControlStyles.AllPaintingInWmPaint Or _
ControlStyles.UserPaint Or _
ControlStyles.DoubleBuffer Or _
ControlStyles.ResizeRedraw, _
True)
m_items = CreateItemCollection()
Dim ver As System.Version = System.Environment.OSVersion.Version()
If (ver.Major > 5) Then
m_isXp = True
ElseIf (ver.Major = 5) Then
If (ver.Minor >= 1) Then
m_isXp = True
End If
End If
End Sub
<System.ComponentModel.Description("Gets/sets the ImageList used to
source icons for this control.")> _
Public Property ImageList() As System.Windows.Forms.ImageList
Get
ImageList = m_imageList
End Get
Set(ByVal Value As System.Windows.Forms.ImageList)
m_imageList = Value
End Set
End Property
<System.ComponentModel.Description("Gets/sets the ToolTip object that
will be used to display ToolTips for this control.")> _
Public Property ToolTip() As System.Windows.Forms.ToolTip
Get
ToolTip = m_toolTip
End Get
Set(ByVal Value As System.Windows.Forms.ToolTip)
m_toolTip = Value
End Set
End Property
<System.ComponentModel.Description("Returns the collection of items
associated with this control.")> _
Public ReadOnly Property Items() As ButtonListBarItems
Get
Items = m_items
End Get
End Property
Public Property ButtonWidth() As Integer
Get
ButtonWidth = m_buttonWidth
End Get
Set(ByVal Value As Integer)
m_buttonWidth = Value
OnItemChanged(Nothing)
End Set
End Property
<System.ComponentModel.Description("Returns the selected item, if any,
within the control.")> _
Public ReadOnly Property SelectedItem() As ButtonListBarItem
Get
Dim item As ButtonListBarItem
For Each item In m_items
If (item.Selected) Then
SelectedItem = item
Exit For
End If
Next
End Get
End Property
Friend Function OnSelectItem(ByVal item As ButtonListBarItem, ByVal
Value As Boolean) As Boolean
Dim i As Integer
If (Value) Then
For i = 0 To m_items.Count - 1
If Not (m_items(i) Is item) Then
If (m_items(i).Selected) Then
m_items(i).Selected = False
End If
End If
Next
Dim e As New SelectionChangedEventArgs(item)
OnSelectionChanged(e)
OnSelectItem = Value
Else
OnSelectItem = Value
End If
End Function
Friend Sub OnItemChanged(ByVal item As ButtonListBarItem)
'
Dim minHeight = 0
If Not (m_items Is Nothing) Then
If (m_items.Count > 0) Then
' Measure all the items & evaluate the overall height
Dim useXpStyles As Boolean = m_isXp
Dim hTheme As IntPtr = IntPtr.Zero
If (useXpStyles) Then
hTheme = OpenThemeData(Me.Handle, UXTHEMEBUTTONCLASS)
If (hTheme.Equals(IntPtr.Zero)) Then
useXpStyles = False
End If
End If
Dim barItem As ButtonListBarItem
Dim lastBarItem As ButtonListBarItem
Dim iconSize As Integer
Dim gfx As Graphics = Graphics.FromHwnd(Me.Handle)
If Not (m_imageList Is Nothing) Then
iconSize = m_imageList.ImageSize.Height
End If
If (useXpStyles) Then
Dim tTextR As RECT
Dim tTextBoundR As RECT
Dim lR As Integer
Dim hdc As IntPtr = gfx.GetHdc()
Dim hFont As IntPtr = Me.Font.ToHfont
Dim hFontOld As IntPtr = SelectObject(hdc, hFont)
For Each barItem In m_items
Dim itemText As String = barItem.Text
tTextR.top = 0
tTextR.bottom = 1280
tTextR.left = 6
tTextR.right = m_buttonWidth - 12
tTextBoundR.top = 0
tTextBoundR.bottom = 1280
tTextBoundR.left = 3
tTextBoundR.right = m_buttonWidth - 12
lR = GetThemeTextExtent( _
hTheme, _
hdc, _
TP_BUTTON, _
TS_NORMAL, _
itemText, -1, _
DT_CENTER Or DT_WORDBREAK, _
tTextBoundR, tTextR)
'Console.WriteLine("GetThemeTextExtent {0}, {1},
{2}", lR, barItem.Text, tTextR.ToString())
If (lastBarItem Is Nothing) Then
barItem.Start() = 4
Else
barItem.Start() = lastBarItem.Start +
lastBarItem.Extent + 4
End If
barItem.Extent = tTextR.bottom - tTextR.top + 4 +
iconSize + 6
minHeight = barItem.Start + barItem.Extent
lastBarItem = barItem
Next
SelectObject(hdc, hFontOld)
DeleteObject(hFont)
gfx.ReleaseHdc(hdc)
CloseThemeData(hTheme)
Else
Dim fmt As StringFormat = New StringFormat()
fmt.Alignment = StringAlignment.Center
fmt.LineAlignment = StringAlignment.Near
fmt.Trimming = StringTrimming.None
fmt.HotkeyPrefix = Drawing.Text.HotkeyPrefix.Show
For Each barItem In m_items
Dim itemText As String = barItem.Text
Dim itemHeight = gfx.MeasureString(itemText,
Me.Font, m_buttonWidth - 12, fmt).Height
Console.WriteLine("GDI+ String Height {0}, {1}",
itemText, itemHeight)
If (lastBarItem Is Nothing) Then
barItem.Start() = 4
Else
barItem.Start() = lastBarItem.Start +
lastBarItem.Extent + 4
End If
barItem.Extent = itemHeight + 4 + iconSize + 6
minHeight = barItem.Start + barItem.Extent
lastBarItem = barItem
Next
fmt.Dispose()
End If
gfx.Dispose()
minHeight = minHeight + 3
End If
End If
Dim scrollChanged As Boolean = False
Dim showScroll As Boolean = False
If (minHeight > Me.Height) Then
showScroll = True
End If
Me.AutoScrollMinSize = New Size(0, minHeight)
If Not (m_showScroll = showScroll) Or _
Not (m_lastButtonWidth = m_buttonWidth) Then
If (showScroll) Then
Me.Width = m_buttonWidth + GetSystemMetrics(SM_CXVSCROLL)
Else
Me.Width = m_buttonWidth
End If
m_showScroll = showScroll
m_lastButtonWidth = m_buttonWidth
Else
Me.Invalidate()
End If
'
End Sub
<System.ComponentModel.Description("Called to create the internal item
collection for this control.")> _
Protected Overridable Function CreateItemCollection() As
ButtonListBarItems
CreateItemCollection = New ButtonListBarItems(Me)
End Function
<System.ComponentModel.Description("Processes key strokes in the
control.")> _
Protected Overrides Sub OnKeyDown(ByVal e As KeyEventArgs)
MyBase.OnKeyDown(e)
If Not (m_items Is Nothing) Then
If (m_items.Count > 0) Then
Dim lNewIndex As Integer = -1
Dim lCurrentIndex As Integer = -1
Dim lMouseOverIndex As Integer = -1
Dim bFound As Boolean
Dim i As Integer
For i = 0 To m_items.Count - 1
If (m_items(i).MouseOver) Then
lMouseOverIndex = i
End If
If (m_items(i).Selected) Then
lCurrentIndex = i
End If
Next i
If (lMouseOverIndex > 0) Then
lCurrentIndex = lMouseOverIndex
End If
Select Case e.KeyCode
Case Keys.Up
lNewIndex = selectNext(lCurrentIndex, -1)
Case Keys.Down
lNewIndex = selectNext(lCurrentIndex, 1)
Case Keys.PageUp
lNewIndex = selectNext(lCurrentIndex, -4)
Case Keys.PageDown
lNewIndex = selectNext(lCurrentIndex, 4)
Case Keys.Home
lNewIndex = 1
Do While Not bFound
If (m_items(lNewIndex).Enabled) Then
bFound = True
Else
lNewIndex = lNewIndex + 1
If (lNewIndex >= m_items.Count) Then
bFound = True
End If
End If
Loop
Case Keys.End
lNewIndex = m_items.Count - 1
Do While Not bFound
If (m_items(lNewIndex).Enabled) Then
bFound = True
Else
lNewIndex = lNewIndex - 1
If (lNewIndex < 0) Then
bFound = True
End If
End If
Loop
Case Keys.Enter
If (lMouseOverIndex >= 0) Then
m_items(lMouseOverIndex).Selected = True
m_items(lMouseOverIndex).MouseOver = False
For i = 0 To m_items.Count - 1
m_items(i).MouseOver = False
Next
ensureVisible(lMouseOverIndex)
Dim itemClickArgs As ItemClickEventArgs = New
ItemClickEventArgs(m_items(lMouseOverIndex),
Nothing, MouseButtons.None)
OnItemClick(itemClickArgs)
End If
End Select
If (lNewIndex <> lCurrentIndex) And (lNewIndex > -1) And
(lNewIndex < m_items.Count) Then
For i = 0 To m_items.Count - 1
If (i = lNewIndex) Then
m_items(i).MouseOver = True
Else
m_items(i).MouseOver = False
End If
Next i
ensureVisible(lNewIndex)
Me.Invalidate()
End If
End If
End If
End Sub
Private Function selectNext( _
ByVal lCurrent As Integer, _
ByVal lDir As Integer _
) As Integer
Dim bFound As Boolean
Dim lNewIndex As Integer
Dim lLastChecked As Integer
lLastChecked = lCurrent
Do While Not (bFound)
lNewIndex = lLastChecked + lDir
If (lNewIndex < 0) Or (lNewIndex >= m_items.Count) Then
If (Math.Abs(lDir) > 1) Then
' equivalent to hitting Home or End:
If (Math.Sign(lDir) = 1) Then
' End
lNewIndex = m_items.Count - 1
Do While Not bFound
If (m_items(lNewIndex).Enabled) Then
bFound = True
Else
lNewIndex = lNewIndex - 1
If (lNewIndex < 0) Then
bFound = True
End If
End If
Loop
Else
' Home
lNewIndex = 0
Do While Not bFound
If (m_items(lNewIndex).Enabled) Then
bFound = True
Else
lNewIndex = lNewIndex + 1
If (lNewIndex >= m_items.Count) Then
bFound = True
End If
End If
Loop
End If
End If
bFound = True
Else
lLastChecked = lNewIndex
If (m_items(lNewIndex).Enabled) Then
bFound = True
End If
lDir = Math.Sign(lDir)
End If
Loop
selectNext = lNewIndex
End Function
<System.ComponentModel.Description("Ensures the keyboard interface
responds correctly in the control.")> _
Protected Overrides Function IsInputKey(ByVal keyData As
System.Windows.Forms.Keys) As Boolean
Dim ret As Boolean = MyBase.IsInputKey(keyData)
Select Case keyData
Case Keys.Up
ret = True
Case Keys.Down
ret = True
Case Keys.Right
ret = True
Case Keys.Left
ret = True
Case Keys.Enter
ret = True
End Select
IsInputKey = ret
End Function
<System.ComponentModel.Description("Performs control painting.")> _
Protected Overrides Sub OnPaint(ByVal e As
System.Windows.Forms.PaintEventArgs)
'
' Clear the background
Dim br As Brush = New SolidBrush(Me.BackColor)
e.Graphics.FillRectangle(br, e.ClipRectangle)
br.Dispose()
If (m_items Is Nothing) Then
Exit Sub
End If
If (m_items.Count = 0) Then
Exit Sub
End If
' Paint the buttons:
Dim useXpStyles As Boolean = m_isXp
Dim hTheme As IntPtr = IntPtr.Zero
If (useXpStyles) Then
hTheme = OpenThemeData(Me.Handle, UXTHEMETOOLBARCLASS)
If (hTheme.Equals(IntPtr.Zero)) Then
useXpStyles = False
End If
End If
Dim iconSize As Integer = 0
If Not (m_imageList Is Nothing) Then
iconSize = m_imageList.ImageSize.Height
End If
Dim barItem As ButtonListBarItem = Nothing
Dim iStateId As Integer = 0
Dim itemText As String = ""
If (useXpStyles) Then
' Drawing using XP Styles
Dim hDC As IntPtr = e.Graphics.GetHdc()
Dim tR As New RECT()
tR.left = 0
tR.right = m_buttonWidth
tR.top = 0
tR.bottom = Me.Height
Dim tItemR As New RECT()
Dim tContentR As New RECT()
Dim tIconR As New RECT()
Dim hFont As IntPtr = Me.Font.ToHfont
Dim hFontOld As IntPtr = IntPtr.Zero
hFontOld = SelectObject(hDC, hFont)
Dim textAlign As Integer
textAlign = DT_CENTER Or DT_WORDBREAK
For Each barItem In m_items
tItemR.left = tR.left + 3
tItemR.right = tR.right - 3
tItemR.top = barItem.Start + Me.AutoScrollPosition.Y
tItemR.bottom = barItem.Start + barItem.Extent +
Me.AutoScrollPosition.Y
If (barItem.Enabled) Then
If (barItem.MouseDown) Then
If (barItem.MouseOver) Then
If (barItem.Selected) Then
iStateId = TS_HOTCHECKED
Else
iStateId = TS_PRESSED
End If
Else
If (barItem.Selected) Then
iStateId = TS_CHECKED
Else
iStateId = TS_HOT
End If
End If
Else
If (barItem.MouseOver) Then
If (barItem.Selected) Then
iStateId = TS_HOTCHECKED
Else
iStateId = TS_HOT
End If
Else
If (barItem.Selected) Then
iStateId = TS_CHECKED
Else
iStateId = TS_NORMAL
End If
End If
End If
Else
iStateId = TS_DISABLED
End If
DrawThemeBackground(hTheme, hDC, TP_BUTTON, iStateId, _
tItemR, tItemR)
GetThemeBackgroundContentRect(hTheme, hDC, TP_BUTTON,
iStateId, _
tItemR, tContentR)
If (iStateId = TS_DISABLED) Then
CloseThemeData(hTheme)
hTheme = OpenThemeData(Me.Handle, UXTHEMEBUTTONCLASS)
iStateId = PBS_DISABLED
End If
tIconR = tContentR
tIconR.left = tContentR.left + (tContentR.right -
tContentR.left - iconSize) \ 2
tIconR.right = tIconR.left + iconSize
tIconR.top += 4
tIconR.bottom = tIconR.top + iconSize
If (iStateId = TS_PRESSED) Then
tIconR.left += 1
tIconR.top += 1
End If
If Not (m_imageList Is Nothing) Then
SelectObject(hDC, hFontOld)
DeleteObject(hFont)
e.Graphics.ReleaseHdc(hDC)
If (barItem.Enabled) Then
e.Graphics.DrawImage( _
m_imageList.Images(barItem.IconIndex), _
tIconR.left, tIconR.top)
Else
ControlPaint.DrawImageDisabled( _
e.Graphics, _
m_imageList.Images(barItem.IconIndex), _
tIconR.left, _
tIconR.top, _
Me.BackColor)
End If
hDC = e.Graphics.GetHdc()
hFont = Me.Font.ToHfont
hFontOld = SelectObject(hDC, hFont)
End If
tContentR.top = tContentR.top + 4 + iconSize
tContentR.left += 3
tContentR.right -= 3
If (iStateId = TS_PRESSED) Then
tContentR.left += 1
tContentR.top += 1
tContentR.right += 1
tContentR.bottom += 1
End If
itemText = barItem.Text
DrawThemeText(hTheme, hDC, BP_PUSHBUTTON, iStateId, _
itemText, -1, _
textAlign, _
IIf(barItem.Enabled, 0, DTT_GRAYED), _
tContentR)
If (iStateId = TS_DISABLED) Then
CloseThemeData(hTheme)
hTheme = OpenThemeData(Me.Handle, UXTHEMETOOLBARCLASS)
End If
Next
CloseThemeData(hTheme)
SelectObject(hDC, hFontOld)
DeleteObject(hFont)
e.Graphics.ReleaseHdc(hDC)
Else
' Drawing using .NET Framework
Dim fmt As StringFormat = New StringFormat()
fmt.Alignment = StringAlignment.Center
fmt.LineAlignment = StringAlignment.Near
fmt.Trimming = StringTrimming.None
fmt.HotkeyPrefix = Drawing.Text.HotkeyPrefix.Show
Dim brText As Brush = New SolidBrush(Me.ForeColor)
For Each barItem In m_items
If (barItem.Enabled) Then
If (barItem.MouseDown) Then
If (barItem.MouseOver) Then
If (barItem.Selected) Then
iStateId = TS_HOTCHECKED
Else
iStateId = TS_PRESSED
End If
Else
If (barItem.Selected) Then
iStateId = TS_CHECKED
Else
iStateId = TS_HOT
End If
End If
Else
If (barItem.MouseOver) Then
If (barItem.Selected) Then
iStateId = TS_HOTCHECKED
Else
iStateId = TS_HOT
End If
Else
If (barItem.Selected) Then
iStateId = TS_CHECKED
Else
iStateId = TS_NORMAL
End If
End If
End If
Else
iStateId = TS_DISABLED
End If
Dim itemRect As New Rectangle(3, barItem.Start,
m_buttonWidth - 6, barItem.Extent)
itemRect.Offset(0, Me.AutoScrollPosition.Y)
' Draw background to item (if necessary);
If (iStateId = TS_CHECKED) Then
e.Graphics.FillRectangle(SystemBrushes.Control,
itemRect)
End If
' Draw border:
If (iStateId = TS_HOTCHECKED) Or (iStateId = TS_CHECKED)
Then
'DrawEdgeAPI(m_cMemDC.hDC, tItemR, BDR_SUNKEN, BF_RECT
Or BF_SOFT)
ControlPaint.DrawBorder3D(e.Graphics, itemRect,
Border3DStyle.Sunken, Border3DSide.All)
ElseIf (iStateId = TS_HOT) Then
'DrawEdgeAPI(m_cMemDC.hDC, tItemR, BDR_RAISED, BF_RECT
Or BF_SOFT)
ControlPaint.DrawBorder3D(e.Graphics, itemRect,
Border3DStyle.Raised, Border3DSide.All)
ElseIf (iStateId = TS_PRESSED) Then
'DrawEdgeAPI(m_cMemDC.hDC, tItemR, BDR_SUNKEN, BF_RECT
Or BF_SOFT)
ControlPaint.DrawBorder3D(e.Graphics, itemRect,
Border3DStyle.Sunken, Border3DSide.All)
End If
itemRect.Inflate(-2, -2)
Dim iconRect As New Rectangle( _
itemRect.X + (itemRect.Width - iconSize) \ 2, _
itemRect.Y + 4, _
iconSize, _
iconSize)
If (iStateId = TS_PRESSED) Then
iconRect.Offset(1, 1)
End If
If Not (m_imageList Is Nothing) Then
If (barItem.Enabled) Then
e.Graphics.DrawImage( _
m_imageList.Images(barItem.IconIndex), _
iconRect.X, iconRect.Y)
Else
ControlPaint.DrawImageDisabled( _
e.Graphics, _
m_imageList.Images(barItem.IconIndex), _
iconRect.X, _
iconRect.Y, _
Me.BackColor)
End If
End If
itemRect.Y = itemRect.Y + iconSize + 4
'itemRect.Inflate(-6, 0)
If (iStateId = TS_PRESSED) Then
itemRect.Offset(1, 1)
End If
Dim textRect As New RectangleF(itemRect.X, itemRect.Y,
itemRect.Width, itemRect.Height)
itemText = barItem.Text
If (iStateId = TS_DISABLED) Then
ControlPaint.DrawStringDisabled(e.Graphics, _
itemText, Me.Font,
Color.FromKnownColor(KnownColor.ControlDark), _
textRect, fmt)
Else
e.Graphics.DrawString( _
itemText, Me.Font, brText, _
textRect, fmt)
End If
Next
brText.Dispose()
fmt.Dispose()
End If
'
End Sub
<System.ComponentModel.Description("Ensures hot-tracking is cleared
when the mouse leaves the control.")> _
Protected Overrides Sub OnMouseLeave(ByVal e As System.EventArgs)
'
MyBase.OnMouseLeave(e)
'
Dim i As Integer
Dim index As Integer
For i = 0 To m_items.Count - 1
If (m_items(i).MouseDown) Then
Exit Sub
Else
If (m_items(i).MouseOver) Then
index = i
End If
End If
Next i
If (index >= 0) And (m_items.Count > 0) Then
If (HitTest() < 0) Then
setToolTip("")
m_items(index).MouseOver = False
Me.Invalidate()
End If
End If
End Sub
<System.ComponentModel.Description("Performs mouse processing in the
control.")> _
Protected Overrides Sub OnMouseDown(ByVal e As
System.Windows.Forms.MouseEventArgs)
'
MyBase.OnMouseDown(e)
Dim index As Integer
Dim itemEventArgs As ItemClickEventArgs
index = HitTest()
If (index > -1) Then
If (e.Button = MouseButtons.Left) Then
m_items(index).MouseDown = True
Me.Invalidate()
ElseIf (e.Button = MouseButtons.Right) Then
itemEventArgs = New ItemClickEventArgs(m_items(index), New
Point(e.X, e.Y), MouseButtons.Right)
OnItemClick(itemEventArgs)
End If
ElseIf (e.Button = MouseButtons.Right) Then
OnBarClick(e)
End If
'
End Sub
Private Sub setToolTip(ByVal sToolTip As String)
If Not (m_toolTip Is Nothing) Then
m_toolTip.SetToolTip(Me, sToolTip)
End If
End Sub
<System.ComponentModel.Description("Performs mouse processing in the
control.")> _
Protected Overrides Sub OnMouseMove(ByVal e As
System.Windows.Forms.MouseEventArgs)
'
MyBase.OnMouseMove(e)
Dim index As Integer
Dim changed As Boolean = False
index = HitTest()
Dim i As Integer
For i = 0 To m_items.Count - 1
If (i = index) Then
If Not (m_items(i).MouseOver) Then
setToolTip(m_items(i).ToolTip)
m_items(i).MouseOver = True
changed = True
End If
Else
If (m_items(i).MouseOver) Then
m_items(i).MouseOver = False
changed = True
End If
End If
Next i
If (index = -1) Then
setToolTip("")
End If
If (changed) Then
Me.Invalidate()
End If
'
End Sub
<System.ComponentModel.Description("Performs mouse processing in the
control.")> _
Protected Overrides Sub OnMouseUp(ByVal e As
System.Windows.Forms.MouseEventArgs)
'
MyBase.OnMouseUp(e)
If (e.Button = MouseButtons.Left) Then
Dim i As Integer
Dim changed As Boolean
For i = 0 To m_items.Count - 1
If (m_items(i).MouseDown) Then
If (HitTest() = i) Then
If (m_items(i).Enabled) Then
' Click
m_items(i).MouseDown = False
m_items(i).Selected = True
ensureVisible(i)
Me.Invalidate()
Dim itemEventArgs As ItemClickEventArgs = New
ItemClickEventArgs( _
m_items(i), _
New Point(e.X, e.Y), _
MouseButtons.Left)
OnItemClick(itemEventArgs)
Else
m_items(i).MouseDown = False
End If
Else
' no click
m_items(i).MouseDown = False
changed = True
End If
End If
Next i
If (changed) Then
Me.Invalidate()
End If
End If
'
End Sub
Private Sub ensureVisible(ByVal lIndex As Integer)
'
Dim lOffset As Integer
lOffset = Me.AutoScrollPosition.Y
Dim lTop As Integer
lTop = m_items(lIndex).Start + lOffset - 3
Dim lNewValue As Integer
If (lTop < 0) Then
' need to scroll up
lNewValue = (-lOffset) + lTop
If (lNewValue <= 2) Then
lNewValue = 0
End If
pScrollTo(lNewValue)
Else
Dim lBottom As Integer
lBottom = m_items(lIndex).Start + lOffset - 3 +
m_items(lIndex).Extent
If (lBottom > Me.ClientSize.Height) Then
' need to scroll down
lNewValue = -Me.AutoScrollPosition.Y + (lBottom -
Me.ClientSize.Height) + 6
If (lNewValue >= Me.AutoScrollMinSize.Height - 4) Then
lNewValue = Me.AutoScrollMinSize.Height
End If
pScrollTo(lNewValue)
End If
End If
'
End Sub
Private Sub pScrollTo(ByVal lNewPos As Integer)
Dim lNow As Integer
Dim lStepSize As Integer
Dim bComplete As Boolean
Dim lNewValue As Integer
lNow = -Me.AutoScrollPosition.Y
If (lNewPos > lNow) Then
lStepSize = 1
Else
lStepSize = -1
End If
Do While Not bComplete
lNewValue = lNow + lStepSize
If (lStepSize < 0) Then
If (lNewValue < lNewPos) Then
lNewValue = lNewPos
bComplete = True
End If
Else
If (lNewValue > lNewPos) Then
lNewValue = lNewPos
bComplete = True
End If
End If
Me.AutoScrollPosition = New Point(0, Math.Abs(lNewValue))
lStepSize = lStepSize * 2
Loop
End Sub
<System.ComponentModel.Description("Processes Alt- Mnemonic key strokes
for the items in the control.")> _
Protected Overrides Function ProcessMnemonic(ByVal charCode As Char) As
Boolean
'
Dim ret As Boolean = MyBase.ProcessMnemonic(charCode)
Dim i As Integer
Dim itemText As String
Dim pos As Integer
Dim compareText As String
Dim index As Integer = -1
compareText = "&" + Char.ToUpper(charCode)
For i = 0 To m_items.Count - 1
itemText = m_items(i).Text.ToUpper()
pos = itemText.IndexOf(compareText)
If (pos > 0) Then
index = i
ret = True
Exit For
End If
Next
If (index > -1) Then
m_items(index).Selected = True
ensureVisible(index)
Dim itemClickArgs As ItemClickEventArgs = New
ItemClickEventArgs(m_items(i), Nothing, MouseButtons.None)
OnItemClick(itemClickArgs)
End If
ProcessMnemonic = ret
'
End Function
<System.ComponentModel.Description("Raises the ItemClick event.")> _
Protected Overridable Sub OnItemClick(ByVal e As ItemClickEventArgs)
RaiseEvent ItemClick(Me, e)
End Sub
<System.ComponentModel.Description("Raises the BarClick event.")> _
Protected Overridable Sub OnBarClick(ByVal e As MouseEventArgs)
RaiseEvent BarClick(Me, e)
End Sub
<System.ComponentModel.Description("Raises the SelectionChanged
event.")> _
Protected Overridable Sub OnSelectionChanged(ByVal e As
SelectionChangedEventArgs)
RaiseEvent SelectionChanged(Me, e)
End Sub
<System.ComponentModel.Description("Performs control resizing.")> _
Protected Overrides Sub OnResize(ByVal e As System.EventArgs)
'
MyBase.OnResize(e)
OnItemChanged(Nothing)
'
End Sub
Private Function HitTest() As Integer
Dim p As New Point(Cursor.Position.X, Cursor.Position.Y)
p = Me.PointToClient(p)
HitTest = HitTestPoint(p.X, p.Y)
End Function
Private Function HitTestPoint(ByVal x As Integer, ByVal y As Integer)
As Integer
Dim ret As Integer = -1
If (x >= 3) And (x <= m_buttonWidth - 6) Then
If (y >= 0 And y <= Me.ClientSize.Height) Then
Dim barItem As ButtonListBarItem
Dim i As Integer
For i = 0 To m_items.Count - 1
barItem = m_items(i)
If (y >= barItem.Start + Me.AutoScrollPosition.Y) Then
If (y < barItem.Start + barItem.Extent +
Me.AutoScrollPosition.Y) Then
ret = i
Exit For
End If
End If
Next
End If
End If
HitTestPoint = ret
End Function
End Class
#End Region
#Region " ButtonListBarItems "
Public Class ButtonListBarItems
Inherits CollectionBase
Private m_owner As ButtonListBar = Nothing
<System.ComponentModel.DescriptionAttribute("Adds an item to the
Listbar.")> _
Public Sub Add(ByVal item As ButtonListBarItem)
item.Owner = m_owner
MyBase.InnerList.Add(item)
m_owner.OnItemChanged(item)
End Sub
<System.ComponentModel.DescriptionAttribute("Adds an array of items to
the Listbar.")> _
Public Sub Add(ByVal items() As ButtonListBarItem)
Dim item As ButtonListBarItem
For Each item In items
If Not (item Is Nothing) Then
item.Owner = m_owner
MyBase.InnerList.Add(item)
End If
Next
m_owner.OnItemChanged(Nothing)
End Sub
<System.ComponentModel.DescriptionAttribute("Inserts an item to the
Listbar at the specified zero-based index.")> _
Public Sub Insert( _
ByVal index As Integer, _
ByVal item As ButtonListBarItem _
)
item.Owner = m_owner
MyBase.InnerList.Insert(index, item)
m_owner.OnItemChanged(item)
End Sub
<System.ComponentModel.DescriptionAttribute("Gets/sets the item with
the specified index.")> _
Default Public Property Item(ByVal index As Integer) As
ButtonListBarItem
Get
Item = MyBase.InnerList(index)
End Get
Set(ByVal Value As ButtonListBarItem)
MyBase.InnerList(index) = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Creates a new, blank
instance of the class for the specified ButtonListBar.")> _
Public Sub New(ByVal owner As ButtonListBar)
m_owner = owner
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class for the specified ButtonListBar and populates the item
collection using the array of ButtonListBarItem objects passed in.")> _
Public Sub New( _
ByVal owner As ButtonListBar, _
ByVal items As ButtonListBarItem() _
)
m_owner = owner
Dim barItem As ButtonListBarItem
For Each barItem In items
barItem.Owner = m_owner
MyBase.InnerList.Add(barItem)
Next
m_owner.OnItemChanged(Nothing)
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class for the specified ButtonListBar and populates it by cloning
the items in the provided ButtonListBarItems collection passed in.")> _
Public Sub New( _
ByVal owner As ButtonListBar, _
ByVal items As ButtonListBarItems _
)
m_owner = owner
Dim barItemFrom As ButtonListBarItem
Dim barItemNew As ButtonListBarItem
For Each barItemFrom In items
barItemNew = barItemFrom.Clone()
barItemNew.Owner = m_owner
MyBase.InnerList.Add(barItemNew)
Next
m_owner.OnItemChanged(Nothing)
End Sub
Protected Overrides Sub OnRemoveComplete(ByVal index As Integer, ByVal
value As Object)
MyBase.OnRemoveComplete(index, value)
' notify parent:
m_owner.OnItemChanged(Nothing)
End Sub
Protected Overrides Sub OnClearComplete()
MyBase.OnClearComplete()
' notify parent:
m_owner.OnItemChanged(Nothing)
End Sub
Protected Overrides Sub OnInsertComplete(ByVal index As Integer, ByVal
value As Object)
MyBase.OnInsertComplete(index, value)
Dim item As ButtonListBarItem = value
item.Owner = m_owner
' notify parent:
m_owner.OnItemChanged(Nothing)
End Sub
Protected Overrides Sub OnSetComplete(ByVal index As Integer, ByVal
oldValue As Object, ByVal newValue As Object)
MyBase.OnSetComplete(index, oldValue, newValue)
Dim item As ButtonListBarItem = newValue
item.Owner = m_owner
' notify parent:
m_owner.OnItemChanged(Nothing)
End Sub
End Class
#End Region
#Region " ButtonListBarItem "
Public Class ButtonListBarItem
Implements ICloneable
Private m_caption As String = ""
Private m_toolTip As String = ""
Private m_tag As Object = Nothing
Private m_iconIndex As Integer = -1
Private m_enabled As Boolean = True
Private m_start As Integer = 0
Private m_extent As Integer = 0
Private m_owner As ButtonListBar = Nothing
Private m_mouseOver As Boolean = False
Private m_mouseDown As Boolean = False
Private m_selected As Boolean = False
<System.ComponentModel.DescriptionAttribute("Gets/sets the text for
this item")> _
Public Property Text() As String
Get
Text = m_caption
End Get
Set(ByVal Value As String)
m_caption = Value
If Not (m_owner Is Nothing) Then
m_owner.OnItemChanged(Me)
End If
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets the tooltip for
this item")> _
Public Property ToolTip() As String
Get
ToolTip = m_toolTip
End Get
Set(ByVal Value As String)
m_toolTip = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets an object
associated with this item")> _
Public Property Tag() As Object
Get
Tag = m_tag
End Get
Set(ByVal Value As Object)
m_tag = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets the icon index
for this item")> _
Public Property IconIndex() As Integer
Get
IconIndex = m_iconIndex
End Get
Set(ByVal Value As Integer)
m_iconIndex = Value
If Not (m_owner Is Nothing) Then
m_owner.OnItemChanged(Me)
End If
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets whether this
item is enabled")> _
Public Property Enabled() As Boolean
Get
Enabled = m_enabled
End Get
Set(ByVal Value As Boolean)
m_enabled = Value
If Not (m_owner Is Nothing) Then
m_owner.OnItemChanged(Me)
End If
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets the owning
ButtonListBar for this item")> _
Friend Property Owner() As ButtonListBar
Get
Owner = m_owner
End Get
Set(ByVal Value As ButtonListBar)
m_owner = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets the start
position of the item in the bar. For internal use only")> _
Friend Property Start() As Integer
Get
Start = m_start
End Get
Set(ByVal Value As Integer)
m_start = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Gets/sets the extent of
the item in the bar. For internal use only")> _
Friend Property Extent() As Integer
Get
Extent = m_extent
End Get
Set(ByVal Value As Integer)
m_extent = Value
End Set
End Property
Public Property Selected() As Boolean
Get
Selected = m_selected
End Get
Set(ByVal Value As Boolean)
If (Value <> m_selected) Then
If Not (m_owner Is Nothing) Then
m_selected = m_owner.OnSelectItem(Me, Value)
m_owner.OnItemChanged(Me)
End If
End If
End Set
End Property
Friend Property MouseDown() As Boolean
Get
MouseDown = m_mouseDown
End Get
Set(ByVal Value As Boolean)
m_mouseDown = Value
End Set
End Property
Friend Property MouseOver() As Boolean
Get
MouseOver = m_mouseOver
End Get
Set(ByVal Value As Boolean)
m_mouseOver = Value
End Set
End Property
<System.ComponentModel.DescriptionAttribute("Creates a copy of this
object.")> _
Public Function Clone() As Object Implements System.ICloneable.Clone
Dim myClone As New ButtonListBarItem( _
m_caption, _
m_iconIndex, _
m_toolTip, _
m_enabled)
myClone.Tag = m_tag
Clone = myClone
End Function
<System.ComponentModel.DescriptionAttribute("Creates a new, blank
instance of the class.")> _
Public Sub New()
MyBase.New()
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class and sets the Text property.")> _
Public Sub New(ByVal text As String)
MyBase.New()
m_caption = text
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class and sets the Text and Icon Index properties.")> _
Public Sub New( _
ByVal text As String, _
ByVal iconIndex As Integer _
)
MyBase.New()
m_caption = text
m_iconIndex = iconIndex
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class and sets the Text, Icon Index and ToolTip properties.")> _
Public Sub New( _
ByVal text As String, _
ByVal iconIndex As Integer, _
ByVal toolTip As String _
)
MyBase.New()
m_caption = text
m_iconIndex = iconIndex
m_toolTip = toolTip
End Sub
<System.ComponentModel.DescriptionAttribute("Creates a new instance of
the class and sets the Text, Icon Index, ToolTip and Enabled
properties.")> _
Public Sub New( _
ByVal text As String, _
ByVal iconIndex As Integer, _
ByVal toolTip As String, _
ByVal enabled As Boolean _
)
MyBase.New()
m_caption = text
m_iconIndex = iconIndex
m_toolTip = toolTip
m_enabled = enabled
End Sub
End Class
#End Region
End Namespace
