vbAccelerator - Contents of code file: vbalARListBar.ctl

VERSION 5.00
Begin VB.UserControl vbalARListBar 
   Alignable       =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   ToolboxBitmap   =   "vbalARListBar.ctx":0000
End
Attribute VB_Name = "vbalARListBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' ===========================================================================
' Name:     vbalARListBar.ctl
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     20 April 2003
' Requires: SSUBTMR.DLL
'           vbaCOMTLB.TLB
'
' ---------------------------------------------------------------------------
' Copyright  2003 Steve McMahon (steve@vbaccelerator.com)
' Visit vbAccelerator - free, advanced source code for VB programmers.
'     http://vbaccelerator.com
' ---------------------------------------------------------------------------
'
' Description:
' VB implementation of Windows Add/Remove programs style
' ListBar.
'
' Updates:
' 2003-07-02
'  * Added Mouse Wheel Support.  Thanks to Chris Eastwood for
'    the suggestion and starter code.
'    Visit his site at http://vbcodelibrary.co.uk/
'  * Control now gets focus when scroll bar clicked
'  * Icons did not draw when using VB6 MSCOMCTL.OCX ImageList; now
'    the native MSCOMCTL.OCX method is used.
' ===========================================================================


' ---------------------------------------------------------------------
' vbAccelerator Software License
' Version 1.0
' Copyright (c) 2002 vbAccelerator.com
'
' Redistribution and use in source and binary forms, with or
' without modification, are permitted provided that the following
' conditions are met:
'
' 1. Redistributions of source code must retain the above copyright
'    notice, this list of conditions and the following disclaimer.
'
' 2. Redistributions in binary form must reproduce the above copyright
'    notice, this list of conditions and the following disclaimer in
'    the documentation and/or other materials provided with the distribution.
'
' 3. The end-user documentation included with the redistribution, if any,
'    must include the following acknowledgment:
'
'  "This product includes software developed by vbAccelerator
 (http://vbaccelerator.com/)."
'
' Alternately, this acknowledgment may appear in the software itself, if
' and wherever such third-party acknowledgments normally appear.
'
' 4. The name "vbAccelerator" must not be used to endorse or promote products
'    derived from this software without prior written permission. For written
'    permission, please contact vbAccelerator through steve@vbaccelerator.com.
'
' 5. Products derived from this software may not be called "vbAccelerator",
'    nor may "vbAccelerator" appear in their name, without prior written
'    permission of vbAccelerator.
'
' THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESSED OR IMPLIED WARRANTIES,
' INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
' AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
' VBACCELERATOR OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
' INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
' BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
' USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
' THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' ---------------------------------------------------------------------


Private Type SIZE
   cX As Long
   cY As Long
End Type

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As
 Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long)
 As Long
Private Const SM_CXVSCROLL = 2

' Windows keyboard message constants:
Private Const WM_SYSCHAR& = &H106&
Private Const WM_SYSKEYDOWN& = &H104&

Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As
 Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long,
 ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As
 Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
 hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
 As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal
 nBkMode As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function DrawEdgeAPI Lib "user32" Alias "DrawEdge" (ByVal hDC
 As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
   (ByVal hDC As Long, ByVal hBrush As Long, _
   ByVal lpDrawStateProc As Long, _
   ByVal lParam As Long, ByVal wParam As Long, _
   ByVal x As Long, ByVal y As Long, _
   ByVal cX As Long, ByVal cY As Long, _
   ByVal fuFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

'/* Image type */
Private Const DST_COMPLEX = &H0
Private Const DST_TEXT = &H1
Private Const DST_PREFIXTEXT = &H2
Private Const DST_ICON = &H3
Private Const DST_BITMAP = &H4

' /* State type */
Private Const DSS_NORMAL = &H0
Private Const DSS_UNION = &H10         ' /* Gray string appearance */
Private Const DSS_DISABLED = &H20
Private Const DSS_MONO = &H80
Private Const DSS_RIGHT = &H8000


Private Declare Function OpenThemeData Lib "uxtheme.dll" _
   (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
   (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal lhDC As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    pRect As RECT, pClipRect As RECT) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme.dll" _
   (ByVal hwnd As Long, ByVal hDC As Long, prc As RECT) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    pBoundingRect As RECT, pContentRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, ByVal pszText As Long, _
    ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
    ByVal dwTextFlags2 As Long, pRect As RECT) As Long
Private Declare Function DrawThemeIcon Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, pRect As RECT, _
    ByVal hIml As Long, ByVal iImageIndex As Long) As Long
Private Declare Function GetThemePartSize Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, _
   ByVal iStateId As Long, prc As RECT, ByVal eSize As Long, _
   psz As SIZE) As Long
Private Declare Function GetThemeTextExtent Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    ByVal pszText As Long, ByVal iCharCount As Long, _
    ByVal dwTextFlags As Long, pBoundingRect As RECT, _
    pExtentRect As RECT) As Long
Private Declare Function DrawThemeEdge Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, _
   ByVal iPartId As Long, ByVal iStateId As Long, _
   pDestRect As RECT, _
   ByVal uEdge As Long, ByVal uFlags As Long, _
   pContentRect As RECT) As Long
Private Const S_OK = 0
Private Const HWND_DESKTOP = 0

' THEMESIZE
Private Const TS_MIN = 0            '// minimum size
Private Const TS_TRUE = 1           '// size without stretching
Private Const TS_DRAW = 2           '// size that theme mgr will use to draw
 part

' Button class
Private Const UXTHEMEBUTTONCLASS = "Button"
Private Const UXTHEMETOOLBARCLASS = "Toolbar"
' Button part
Private Const TP_BUTTON = 1
Private Const BP_PUSHBUTTON = 1
' Button states
Private Const TS_NORMAL = 1
Private Const TS_HOT = 2
Private Const TS_PRESSED = 3
Private Const TS_DISABLED = 4
Private Const TS_CHECKED = 5
Private Const TS_HOTCHECKED = 6
Private Const PBS_DISABLED = 4

' DrawTextFlags
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8
Private Const DT_WORDBREAK = &H10
Private Const DT_SINGLELINE = &H20
Private Const DT_EXPANDTABS = &H40
Private Const DT_TABSTOP = &H80
Private Const DT_NOCLIP = &H100
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_CALCRECT = &H400
Private Const DT_NOPREFIX = &H800
Private Const DT_INTERNAL = &H1000
Private Const DT_EDITCONTROL = &H2000
Private Const DT_PATH_ELLIPSIS = &H4000
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000
Private Const DT_NOFULLWIDTHCHARBREAK = &H80000
Private Const DT_HIDEPREFIX = &H100000
Private Const DT_PREFIXONLY = &H200000

' UxTheme DrawText Additional Flag
Private Const DTT_GRAYED = &H1             '// draw a grayed-out string

' DrawEdgeEdgeTypes
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const BDR_OUTER = (BDR_RAISEDOUTER Or BDR_SUNKENOUTER)
Private Const BDR_INNER = (BDR_RAISEDINNER Or BDR_SUNKENINNER)
Private Const BDR_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const BDR_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)

' DrawEdgeBorderFlags
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_DIAGONAL = &H10
Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or
 BF_RIGHT)
Private Const BF_MIDDLE = &H800             '/* Fill in the middle */
Private Const BF_SOFT = &H1000              '/* For softer buttons */
Private Const BF_ADJUST = &H2000            '/* Calculate the space left over */
Private Const BF_FLAT = &H4000              '/* For flat rather than 3D borders
 */
Private Const BF_MONO = &H8000              '/* For monochrome borders */

Private Type IMAGELISTDRAWPARAMS
    cbSize As Long
    hIml As Long
    i As Long
    hdcDst As Long
    x As Long
    y As Long
    cX As Long
    cY As Long
    xBitmap As Long
    yBitmap As Long
    rgbBk As Long
    rgbFg As Long
    fStyle As Long
    dwRop As Long
    fState As Long
    Frame As Long
    crEffect As Long
End Type
Private Declare Function ImageList_DrawIndirect Lib "comctl32.dll" ( _
    pimldp As IMAGELISTDRAWPARAMS) As Long
Private Declare Function ImageList_GetImageRect Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
Private Declare Function ImageList_Draw Lib "comctl32.dll" ( _
        ByVal hIml As Long, ByVal i As Long, _
        ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, _
        ByVal fStyle As Long _
    ) As Long
Private Declare Function ImageList_GetIcon Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        ByVal diIgnore As Long _
    ) As Long
Private Declare Function ImageList_Create Lib "COMCTL32" (ByVal MinCx As Long,
 ByVal MinCy As Long, ByVal flags As Long, ByVal cInitial As Long, ByVal cGrow
 As Long) As Long
Private Declare Function ImageList_AddMasked Lib "COMCTL32" (ByVal hImageList
 As Long, ByVal hbmImage As Long, ByVal crMask As Long) As Long
Private Declare Function ImageList_Destroy Lib "COMCTL32" (ByVal hImageList As
 Long) As Long
Private Const ILD_TRANSPARENT = 1
Private Const ILD_BLEND25 = 2
Private Const ILD_SELECTED = 4
Private Const ILD_IMAGE = &H20&
Private Const ILD_PRESERVEALPHA = &H1000&
Private Const ILC_COLOR = &H0
Private Const ILC_COLOR32 = &H20
Private Const ILC_MASK = &H1&
Private Const ILS_SATURATE = &H4&

Private Type tARListBarItem
   sKey As String
   iIconIndex As Long
   sCaption As String
   sToolTip As String
   bEnabled As Boolean
   bSelected As Boolean
   sTag As String
   lItemData As Long
   lID As Long
   yStart As Long
   yExtent As Long
   bMouseOver As Boolean
   bMouseDown As Boolean
End Type

' OleControl Interface support:
Private m_ptrGetControlInfoOrig As Long
Private m_ptrOnMnemonicOrg As Long
Private m_cMnemonics As pcMnemonics

Private WithEvents m_cScroll As pcScrollBars
Attribute m_cScroll.VB_VarHelpID = -1
Private m_cMemDC As pcMemDC
Private WithEvents m_tmr As CTimer
Attribute m_tmr.VB_VarHelpID = -1

Private m_hIml As Long
Private m_ptrVB6ImageList As Long
Private m_lIconSize As Long

Private m_lItemCount As Long
Private m_tItem() As tARListBarItem
Private m_lIDGenerator As Long

Private m_oBackColor As OLE_COLOR
Private m_oForeColor As OLE_COLOR
Private m_fnt As IFont
Private m_lButtonWidth As Long
Private m_lLastButtonWidth As Long

Private m_bIsNt As Boolean
Private m_bIsXp As Boolean
Private m_bRunTime As Boolean
Private m_bFocus As Boolean

Private m_sToolTip As String

Public Event SelectionChanged(ByVal lIndex As Long)
Attribute SelectionChanged.VB_Description = "Raised whenever the selected item
 is changed, either by the user or in code."
Public Event ItemClick(ByVal lIndex As Long)
Attribute ItemClick.VB_Description = "Raised when a new item is selected in the
 control using the mouse or the keyboard."
Public Event ItemRightClick(ByVal lIndex As Long, x As Single, y As Single)
Attribute ItemRightClick.VB_Description = "Raised when an item is
 right-clicked."
Public Event BarRightClick(x As Single, y As Single)
Attribute BarRightClick.VB_Description = "Raised when the bar area of the
 control is right-clicked."
Public Event MouseMove(Button As MouseButtonConstants, Shift As ShiftConstants,
 x As Single, y As Single)
Attribute MouseMove.VB_Description = "Raised when a MouseMove event occurs in
 the control."
Public Event MouseDown(Button As MouseButtonConstants, Shift As ShiftConstants,
 x As Single, y As Single)
Attribute MouseDown.VB_Description = "Raised when a MouseDown event occurs in
 the control."
Public Event MouseUp(Button As MouseButtonConstants, Shift As ShiftConstants, x
 As Single, y As Single)
Attribute MouseUp.VB_Description = "Raised when a MouseUp event occurs in the
 control."
Public Event KeyDown(KeyCode As KeyCodeConstants, Shift As ShiftConstants)
Attribute KeyDown.VB_Description = "Raised when a key down event occurs in the
 control."
Public Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Raised when a KeyPress event occurs in the
 control."
Public Event KeyUp(KeyCode As KeyCodeConstants, Shift As ShiftConstants)
Attribute KeyUp.VB_Description = "Raised when a key is released in the control."

Public Event Resize()
Attribute Resize.VB_Description = "Raised when the control is resized."

Private Sub GetWindowsVersion( _
      Optional ByRef lMajor = 0, _
      Optional ByRef lMinor = 0, _
      Optional ByRef lRevision = 0, _
      Optional ByRef lBuildNumber = 0, _
      Optional ByRef bIsNt = False _
   )
Dim lR As Long
   lR = GetVersion()
   lBuildNumber = (lR And &H7F000000) \ &H1000000
   If (lR And &H80000000) Then lBuildNumber = lBuildNumber Or &H80
   lRevision = (lR And &HFF0000) \ &H10000
   lMinor = (lR And &HFF00&) \ &H100
   lMajor = (lR And &HFF)
   bIsNt = ((lR And &H80000000) = 0)
End Sub

Public Property Get BackColor() As OLE_COLOR
Attribute BackColor.VB_Description = "Gets/sets the background colour of the
 bar.  The special value -1 sets the colour to the default."
   BackColor = m_oBackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
   m_oBackColor = oColor
   If (m_oBackColor = -1) Then
      If (m_bIsXp) Then
         UserControl.BackColor = vbButtonFace
      Else
         UserControl.BackColor = vbButtonShadow
      End If
   Else
      UserControl.BackColor = oColor
   End If
   PropertyChanged "BackColor"
End Property

Public Property Get Font() As StdFont
Attribute Font.VB_Description = "Gets/sets the font used to draw the items in
 the control."
   Set Font = UserControl.Font
End Property
Public Property Let Font(fnt As StdFont)
   Set UserControl.Font = fnt
   PropertyChanged "Font"
End Property
Public Property Set Font(fnt As StdFont)
   Set UserControl.Font = fnt
   PropertyChanged "Font"
End Property

Private Function NextId() As Long
   m_lIDGenerator = m_lIDGenerator + 1
   NextId = m_lIDGenerator
End Function

Public Property Get ButtonWidth() As Single
Attribute ButtonWidth.VB_Description = "Gets/sets the width of buttons in the
 control.  Use this property to set the width of the control: note the actual
 width will vary depending on whether the scroll bar is shown."
   ButtonWidth = pScaleX(m_lButtonWidth)
End Property
Public Property Let ButtonWidth(ByVal fButtonWidth As Single)
   m_lButtonWidth = pUnScaleX(fButtonWidth)
   UserControl_Resize
   pPaint
End Property

Public Sub Add( _
      Optional ByVal sKey As String = "", _
      Optional ByVal sCaption As String = "", _
      Optional ByVal lIconIndex As Long = -1, _
      Optional ByVal sToolTip As String = "", _
      Optional ByVal bEnabled As Boolean = True, _
      Optional ByVal sTag = "", _
      Optional ByVal lItemData = 0, _
      Optional KeyBefore As Variant _
   )
Attribute Add.VB_Description = "Adds or inserts a new item to the bar."
Dim lIndex As Long
Dim lBeforeIndex As Long
Dim i As Long
Dim lID As Long

   ' Check key before
   If Not (IsMissing(KeyBefore)) Then
      On Error Resume Next
      lBeforeIndex = ItemIndex(KeyBefore)
      On Error GoTo 0
      If (lBeforeIndex <= 0) Then
         Err.Raise 9
         Exit Sub
      End If
   End If
   
   ' Check key:
   On Error Resume Next
   lIndex = ItemIndex(sKey)
   On Error GoTo 0
   If (lIndex > 0) Then
      Err.Raise 457
      Exit Sub
   End If
   
   lID = NextId
   If Len(sKey) = 0 Then
      sKey = "ITEM:" & lID
   End If
   
   ' Add the item:
   m_lItemCount = m_lItemCount + 1
   ReDim Preserve m_tItem(1 To m_lItemCount) As tARListBarItem
   
   If (lBeforeIndex > 0) Then
      ' shift everything else down:
      For i = m_lItemCount - 1 To lBeforeIndex Step -1
         LSet m_tItem(i + 1) = m_tItem(i)
      Next i
   Else
      lBeforeIndex = m_lItemCount
   End If
   
   With m_tItem(lBeforeIndex)
      .sKey = sKey
      .sCaption = sCaption
      .iIconIndex = lIconIndex
      .sToolTip = sToolTip
      .sTag = sTag
      .lItemData = lItemData
      .bEnabled = bEnabled
      .lID = lID
   End With
   
   pAddAccessKey sCaption
      
   pResize
   pPaint
   
End Sub

Public Sub Remove(vKey As Variant)
Attribute Remove.VB_Description = "Removes the specified item from the control."
Dim lIndex As Long
Dim i As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      If (m_lItemCount = 1) Then
         Clear
      Else
         For i = lIndex To m_lItemCount - 1
            LSet m_tItem(i) = m_tItem(i + 1)
         Next i
         m_lItemCount = m_lItemCount - 1
         ReDim Preserve m_tItem(1 To m_lItemCount) As tARListBarItem
         pResize
         pPaint
      End If
   End If
End Sub

Public Sub Clear()
Attribute Clear.VB_Description = "Clears all items from the control."
   m_lItemCount = 0
   Erase m_tItem
   pPaint
End Sub

Public Property Get ItemCount() As Long
Attribute ItemCount.VB_Description = "Gets the number of items in the control."
   ItemCount = m_lItemCount
End Property

Public Property Get ItemIndex(vKey As Variant) As Long
Attribute ItemIndex.VB_Description = "Gets the index of the specified item in
 the control."
Dim lIndex As Long
Dim i As Long
   If (IsNumeric(vKey)) Then
      lIndex = CLng(vKey)
      If (lIndex > 0) And (lIndex <= m_lItemCount) Then
         ItemIndex = lIndex
      Else
         Err.Raise 9
      End If
   Else
      For i = 1 To m_lItemCount
         If (m_tItem(i).sKey = vKey) Then
            lIndex = i
            Exit For
         End If
      Next i
      If (lIndex > 0) Then
         ItemIndex = lIndex
      Else
         Err.Raise 9
      End If
   End If
End Property

Public Property Get ItemCaption(vKey As Variant) As String
Attribute ItemCaption.VB_Description = "Gets/sets the caption for the specified
 item."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemCaption = m_tItem(lIndex).sCaption
   End If
End Property
Public Property Let ItemCaption(vKey As Variant, ByVal sCaption As String)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      pAddAccessKey sCaption
      m_tItem(lIndex).sCaption = sCaption
      pResize
      pPaint
   End If
End Property
Public Property Get ItemKey(vKey As Variant) As String
Attribute ItemKey.VB_Description = "Gets/sets the key associated with the
 specified item in the control."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemKey = m_tItem(lIndex).sKey
   End If
End Property
Public Property Let ItemKey(vKey As Variant, ByVal sKey As String)
Dim lIndex As Long
Dim i As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      For i = 1 To m_lItemCount
         If Not (i = lIndex) Then
            If (m_tItem(i).sKey = sKey) Then
               Err.Raise 457
               Exit Property
            End If
         End If
      Next i
      m_tItem(lIndex).sKey = sKey
   End If
End Property
Public Property Get ItemTag(vKey As Variant) As String
Attribute ItemTag.VB_Description = "Gets/sets a string value associated with
 the specified item."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemTag = m_tItem(lIndex).sTag
   End If
End Property
Public Property Let ItemTag(vKey As Variant, ByVal sTag As String)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      m_tItem(lIndex).sTag = sTag
   End If
End Property
Public Property Get ItemToolTip(vKey As Variant) As String
Attribute ItemToolTip.VB_Description = "Gets/sets the tooltip to display for
 the specified item."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemToolTip = m_tItem(lIndex).sToolTip
   End If
End Property
Public Property Let ItemToolTip(vKey As Variant, ByVal sToolTip As String)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      m_tItem(lIndex).sToolTip = sToolTip
   End If
End Property
Public Property Get ItemData(vKey As Variant) As Long
Attribute ItemData.VB_Description = "Gets/sets a long value associated with an
 item."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemData = m_tItem(lIndex).lItemData
   End If
End Property
Public Property Let ItemData(vKey As Variant, ByVal lItemData As Long)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      m_tItem(lIndex).lItemData = lItemData
   End If
End Property
Public Property Get ItemIcon(vKey As Variant) As Long
Attribute ItemIcon.VB_Description = "Gets/sets the 0-based index of the icon
 for the specified item."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemIcon = m_tItem(lIndex).iIconIndex
   End If
End Property
Public Property Let ItemIcon(vKey As Variant, ByVal lIconIndex As Long)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      m_tItem(lIndex).iIconIndex = lIconIndex
      pPaint
   End If
End Property

Public Property Get ItemSelected(vKey As Variant) As Boolean
Attribute ItemSelected.VB_Description = "Gets/sets whether an item is selected
 or not.  Either no items or one item can be selected."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemSelected = m_tItem(lIndex).bSelected
   End If
End Property
Public Property Let ItemSelected(vKey As Variant, ByVal bSelected As Boolean)
Dim lIndex As Long
Dim i As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      If (m_tItem(lIndex).bSelected = bSelected) Then
         ' nothing to do
      Else
         If (bSelected) Then
            For i = 1 To m_lItemCount
               m_tItem(i).bMouseOver = False
               If Not (i = lIndex) Then
                  m_tItem(i).bSelected = False
               End If
            Next i
         End If
         m_tItem(lIndex).bSelected = bSelected
         If (bSelected) Then
            pEnsureVisible lIndex
            RaiseEvent SelectionChanged(lIndex)
         End If
         pPaint
      End If
   End If
End Property
Public Property Get SelectedIndex() As Long
Attribute SelectedIndex.VB_Description = "Gets the selected item in the
 control.  Use the ItemSelected property to set the selected index."
Dim i As Long
   For i = 1 To m_lItemCount
      If (m_tItem(i).bSelected) Then
         SelectedIndex = i
         Exit For
      End If
   Next i
End Property
Public Property Get ItemEnabled(vKey As Variant) As Boolean
Attribute ItemEnabled.VB_Description = "Gets/sets whether the specified item is
 enabled or not."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      ItemEnabled = m_tItem(lIndex).bEnabled
   End If
End Property
Public Property Let ItemEnabled(vKey As Variant, ByVal bEnabled As Boolean)
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      m_tItem(lIndex).bEnabled = bEnabled
      pPaint
   End If
End Property

Public Sub EnsureItemVisible(vKey As Variant)
Attribute EnsureItemVisible.VB_Description = "Ensures the specified item is in
 view, scrolling if required."
Dim lIndex As Long
   lIndex = ItemIndex(vKey)
   If (lIndex > 0) Then
      pEnsureVisible lIndex
   End If
End Sub

Public Property Let ImageList( _
        ByRef vImageList As Variant _
    )
Attribute ImageList.VB_Description = "Sets the ImageList used to draw the
 control.  If using a VB ImageList, set to the ImageList object, otherwise if
 using an API-based ImageList pass in the hImageList or hIml property.  Set to
 0 to clear the ImageList."
    m_hIml = 0
    m_ptrVB6ImageList = 0
    If (VarType(vImageList) = vbLong) Then
        ' Assume a handle to an image list:
        m_hIml = vImageList
    ElseIf (VarType(vImageList) = vbObject) Then
        ' Assume a VB image list:
        On Error Resume Next
        ' Get the image list initialised..
        vImageList.ListImages(1).Draw 0, 0, 0, 1
        m_hIml = vImageList.hImageList
        If (Err.Number = 0) Then
            ' Check for VB6 image list:
            If (TypeName(vImageList) = "ImageList") Then
               Dim o As Object
               Set o = vImageList
               m_ptrVB6ImageList = ObjPtr(o)
            End If
        Else
            Debug.Print "Failed to Get Image list Handle",
             "cARListBar.ImageList"
        End If
        On Error GoTo 0
    End If
    If (m_hIml <> 0) Then
        If (m_ptrVB6ImageList <> 0) Then
            m_lIconSize = vImageList.ImageHeight
        Else
            Dim rc As RECT
            ImageList_GetImageRect m_hIml, 0, rc
            m_lIconSize = rc.bottom - rc.top
        End If
    End If
End Property

Private Sub pAddAccessKey( _
      ByVal sNewCaption As String, _
      Optional ByVal sOldCaption As String = "" _
   )
Dim iPos As Long
Dim sToAdd As String
Dim sToRemove As String
Dim sKeys As String

   iPos = InStr(sNewCaption, "&")
   If (iPos > 0) And (iPos < Len(sNewCaption)) Then
      sToAdd = UCase(Mid(sNewCaption, iPos + 1, 1))
   End If
   
   iPos = InStr(sOldCaption, "&")
   If (iPos > 0) And (iPos < Len(sOldCaption)) Then
      sToRemove = UCase(Mid(sOldCaption, iPos + 1, 1))
   End If
   
   If (sToAdd = sToRemove) Then
      Exit Sub
   Else
      If Len(sToRemove) > 0 Then
         m_cMnemonics.RemoveByKey sToRemove
      End If
      m_cMnemonics.AddByKey sToAdd
      pUpdateMnemonics
   End If
End Sub

Private Function Replace(ByVal sString As String, ByVal sToReplace As String,
 ByVal sReplaceWith As String) As String
Dim iPos As Long
Dim iNextPos As Long
Dim sRet As String
   If Len(sString) > 0 Then
      iPos = 1
      iNextPos = 1
      Do While (iNextPos > 0)
         iNextPos = InStr(sString, iPos, sToReplace)
         If (iNextPos > 0) Then
            sRet = sRet & Mid(sString, iPos, iNextPos - iPos) & sReplaceWith
            iPos = iNextPos + Len(sToReplace)
         End If
      Loop
      sRet = sRet & Mid(sString, iPos)
      Replace = sRet
   End If
End Function

Private Sub pSetToolTip(ByVal sToolTip As String)
   If StrComp(sToolTip, m_sToolTip, vbTextCompare) <> 0 Then
      If Len(sToolTip) = 0 Then
         sToolTip = vbNullChar
      End If
      On Error Resume Next
      UserControl.Extender.ToolTipText = sToolTip
      m_sToolTip = sToolTip
   End If
End Sub

Private Sub pEnsureVisible(ByVal lIndex As Long)
   '
   Dim tR As RECT
   GetClientRect hwnd, tR
   
   Dim lOffset As Long
   If Not m_cScroll Is Nothing Then
      If (m_cScroll.Visible(efsVertical)) Then
         lOffset = m_cScroll.Value(efsVertical)
      End If
   End If
   
   Dim lTop As Long
   lTop = m_tItem(lIndex).yStart - lOffset - 3
   Dim lNewValue As Long
   If (lTop < tR.top) Then
      ' need to scroll up
      lNewValue = m_cScroll.Value(efsVertical) - (tR.top - lTop)
      If (lNewValue <= 2) Then
         lNewValue = 0
      End If
      pScrollTo lNewValue
   Else
      Dim lBottom As Long
      lBottom = m_tItem(lIndex).yStart - lOffset - 3 + m_tItem(lIndex).yExtent
      If (lBottom > tR.bottom) Then
         ' need to scroll down
         lNewValue = m_cScroll.Value(efsVertical) + (lBottom - tR.bottom) + 6
         If (lNewValue > m_cScroll.Max(efsVertical)) Then
            lNewValue = m_cScroll.Max(efsVertical)
         End If
         If (lNewValue >= m_cScroll.Max(efsVertical) - 4) Then
            lNewValue = m_cScroll.Max(efsVertical)
         End If
         pScrollTo lNewValue
      End If
   End If
   '
End Sub

Private Sub pScrollTo(ByVal lNewPos As Long)
Dim lNow As Long
Dim lStepSize As Long
Dim bComplete As Boolean
Dim lNewValue As Long

   lNow = m_cScroll.Value(efsVertical)
   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
      m_cScroll.Value(efsVertical) = lNewValue
      lStepSize = lStepSize * 2
   Loop

End Sub

Private Sub pResize()
Dim bXp As Long
Dim i As Long
Dim lR As Long
Dim tTextBoundR As RECT
Dim tTextR As RECT
Dim hFontOld As Long
Dim iFnt As IFont
Dim tR As RECT
Dim hTheme As Long
Dim bShowScroll As Boolean
Static bScrollResize As Boolean

   If bScrollResize Then
      Exit Sub
   End If
   
   If (m_lItemCount > 0) Then
      GetClientRect UserControl.hwnd, tR
      tR.left = tR.left + 3
      tR.right = tR.left + m_lButtonWidth - 6
      m_cMemDC.Width = m_lButtonWidth
      m_cMemDC.Height = tR.bottom - tR.top
   
      Set iFnt = UserControl.Font
      hFontOld = SelectObject(m_cMemDC.hDC, iFnt.hFont)
      
      ' Measure all the items & count overall height
      bXp = m_bIsXp
      If (bXp) Then
         On Error Resume Next
         hTheme = OpenThemeData(UserControl.hwnd, StrPtr(UXTHEMEBUTTONCLASS))
         On Error GoTo 0
         If (hTheme = 0) Then
            bXp = False
         End If
      End If
   
      If (bXp) Then
         For i = 1 To m_lItemCount
            LSet tTextBoundR = tR
            InflateRect tTextBoundR, -6, -4
            LSet tTextR = tTextBoundR
            lR = GetThemeTextExtent( _
               hTheme, _
               m_cMemDC.hDC, _
               TP_BUTTON, _
               TS_NORMAL, _
               StrPtr(m_tItem(i).sCaption), -1, _
               DT_CENTER Or DT_WORDBREAK, _
               tTextBoundR, tTextR)
            If (i > 1) Then
               m_tItem(i).yStart = m_tItem(i - 1).yStart + m_tItem(i -
                1).yExtent + 4
            Else
               m_tItem(i).yStart = 4
            End If
            m_tItem(i).yExtent = tTextR.bottom - tTextR.top + 4 + m_lIconSize +
             6
         Next i
         
         CloseThemeData hTheme
      Else
         For i = 1 To m_lItemCount
            LSet tTextR = tR
            InflateRect tTextR, -6, -4
            lR = DrawText( _
               m_cMemDC.hDC, _
               m_tItem(i).sCaption, _
               -1, _
               tTextR, _
               DT_CENTER Or DT_WORDBREAK Or DT_CALCRECT)
            If (i > 1) Then
               m_tItem(i).yStart = m_tItem(i - 1).yStart + m_tItem(i -
                1).yExtent + 4
            Else
               m_tItem(i).yStart = 4
            End If
            m_tItem(i).yExtent = tTextR.bottom - tTextR.top + 4 + m_lIconSize +
             6
         Next i
      End If
      
      SelectObject m_cMemDC.hDC, hFontOld
   End If
   
   ' Are scroll bars required?
   If Not (m_cScroll Is Nothing) Then
      If (m_lItemCount > 0) Then
         If (m_tItem(m_lItemCount).yExtent + m_tItem(m_lItemCount).yStart >
          tR.bottom - tR.top) Then
            m_cScroll.Orientation = efsoVertical
            m_cScroll.Min(efsVertical) = 0
            m_cScroll.Max(efsVertical) = (m_tItem(m_lItemCount).yExtent +
             m_tItem(m_lItemCount).yStart - tR.bottom - tR.top) + 3
            m_cScroll.SmallChange(efsVertical) = 10
            m_cScroll.LargeChange(efsVertical) = tR.bottom - tR.top
            bScrollResize = Not (m_cScroll.Visible(efsVertical))
            m_cScroll.Visible(efsVertical) = True
         Else
            bScrollResize = m_cScroll.Visible(efsVertical)
            m_cScroll.Visible(efsVertical) = False
         End If
      Else
         bScrollResize = m_cScroll.Visible(efsVertical)
         m_cScroll.Visible(efsVertical) = False
      End If
   End If
      
   ' Resize the object
   If (bScrollResize) Or Not (m_lLastButtonWidth = m_lButtonWidth) Then
      If Not (m_cScroll Is Nothing) Then
         If (m_cScroll.Visible(efsVertical)) Then
            bShowScroll = True
         End If
      End If
   
      If (bShowScroll) Then
         On Error Resume Next
         UserControl.Extender.Width = UserControl.Extender.Container.ScaleX( _
            (m_lButtonWidth + GetSystemMetrics(SM_CXVSCROLL)), _
            vbPixels, _
            UserControl.Extender.Container.ScaleMode)
         If Not (Err.Number = 0) Then
            ' assume not being used in VB
         End If
      Else
         On Error Resume Next
         UserControl.Extender.Width = UserControl.Extender.Container.ScaleX( _
            m_lButtonWidth, _
            vbPixels, _
            UserControl.Extender.Container.ScaleMode)
         If Not (Err.Number = 0) Then
            ' assume not being used in VB
         End If
      End If
      bScrollResize = False
      m_lLastButtonWidth = m_lButtonWidth
   End If
       
End Sub

Private Function pScaleX(ByVal lPixels As Long) As Single
   pScaleX = UserControl.ScaleX(lPixels, vbPixels, UserControl.ScaleMode)
End Function
Private Function pUnScaleX(ByVal fWidth As Single) As Long
   pUnScaleX = UserControl.ScaleX(fWidth, vbPixels, UserControl.ScaleMode)
End Function

Public Property Get ScaleMode() As ScaleModeConstants
Attribute ScaleMode.VB_Description = "Gets/sets the scale mode used for the
 control."
   ScaleMode = UserControl.ScaleMode
End Property
Public Property Let ScaleMode(ByVal eMode As ScaleModeConstants)
   UserControl.ScaleMode = eMode
   PropertyChanged "ScaleMode"
End Property

Private Sub pClearBackground(tR As RECT)
Dim oBackColor As OLE_COLOR
Dim hBr As Long

   If (m_oBackColor = -1) Then
      If (m_bIsXp) Then
         oBackColor = vbButtonFace
      Else
         oBackColor = vbButtonShadow
      End If
   Else
      oBackColor = m_oBackColor
   End If
   
   If (oBackColor And &H80000000) Then
      hBr = GetSysColorBrush(oBackColor And &H1F&)
   Else
      hBr = CreateSolidBrush(TranslateColor(oBackColor))
   End If
   
   FillRect m_cMemDC.hDC, tR, hBr
   
   DeleteObject hBr
   
End Sub

Private Sub pDrawItems(tR As RECT)
Dim i As Long
Dim hTheme As Long
Dim bXp As Boolean
Dim hFontOld As Long
Dim iFnt As IFont
Dim tItemR As RECT
Dim tContentR As RECT
Dim tIconR As RECT
Dim iStateId As Long
Dim lOffset As Long
Dim sClasses As String
Dim lPressOffset As Long
Dim hBr As Long
   
   Set iFnt = UserControl.Font
   hFontOld = SelectObject(m_cMemDC.hDC, iFnt.hFont)

   bXp = m_bIsXp
   If (bXp) Then
      On Error Resume Next
      hTheme = OpenThemeData(UserControl.hwnd, StrPtr(UXTHEMETOOLBARCLASS))
      On Error GoTo 0
      If (hTheme = 0) Then
         bXp = False
      End If
   End If
   
   If Not (m_cScroll Is Nothing) Then
      If (m_cScroll.Visible(efsVertical)) Then
         lOffset = m_cScroll.Value(efsVertical)
      End If
   End If

   If (bXp) Then
      
      For i = 1 To m_lItemCount
         LSet tItemR = tR
         tItemR.top = m_tItem(i).yStart
         tItemR.bottom = tItemR.top + m_tItem(i).yExtent
         OffsetRect tItemR, 0, -lOffset
         If (m_tItem(i).bEnabled) Then
            If (m_tItem(i).bMouseDown) Then
               If (m_tItem(i).bMouseOver) Then
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_HOTCHECKED
                  Else
                     iStateId = TS_PRESSED
                  End If
               Else
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_CHECKED
                  Else
                     iStateId = TS_HOT
                  End If
               End If
            Else
               If (m_tItem(i).bMouseOver) Then
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_HOTCHECKED
                  Else
                     iStateId = TS_HOT
                  End If
               Else
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_CHECKED
                  Else
                     iStateId = TS_NORMAL
                  End If
               End If
            End If
         Else
            iStateId = TS_DISABLED
         End If
         
         DrawThemeBackground hTheme, m_cMemDC.hDC, TP_BUTTON, iStateId, _
            tItemR, tItemR
         GetThemeBackgroundContentRect hTheme, m_cMemDC.hDC, TP_BUTTON,
          iStateId, _
            tItemR, tContentR
         
         If (iStateId = TS_DISABLED) Then
            CloseThemeData hTheme
            hTheme = OpenThemeData(UserControl.hwnd, StrPtr(UXTHEMEBUTTONCLASS))
            iStateId = PBS_DISABLED
         End If
         
         LSet tIconR = tContentR
         tIconR.left = tContentR.left + (tContentR.right - tContentR.left -
          m_lIconSize) \ 2
         tIconR.right = tIconR.left + m_lIconSize
         tIconR.top = tIconR.top + 4
         tIconR.bottom = tIconR.top + m_lIconSize
         If (iStateId = TS_PRESSED) Then
            OffsetRect tIconR, 1, 1
         End If
         
         If (m_tItem(i).bEnabled) Then
            If (m_ptrVB6ImageList = 0) Then
               DrawThemeIcon hTheme, m_cMemDC.hDC, TP_BUTTON, iStateId, _
                  tIconR, m_hIml, m_tItem(i).iIconIndex
            Else
               ' need to draw the icon using standard means
               ImageListDrawIcon m_ptrVB6ImageList, m_cMemDC.hDC, m_hIml, _
                  m_tItem(i).iIconIndex, _
                  tContentR.left + (tContentR.right - tContentR.left -
                   m_lIconSize) \ 2, _
                  tContentR.top + 4
               
            End If
         Else
            ImageListDrawIconDisabled m_ptrVB6ImageList, m_cMemDC.hDC, m_hIml, _
               m_tItem(i).iIconIndex, _
               tIconR.left, _
               tIconR.top, _
               m_lIconSize
         End If
         
         tContentR.top = tContentR.top + 4 + m_lIconSize
         InflateRect tContentR, -6, 0
         If (iStateId = TS_PRESSED) Then
            OffsetRect tContentR, 1, 1
         End If
                  
         DrawThemeText hTheme, m_cMemDC.hDC, BP_PUSHBUTTON, iStateId, _
            StrPtr(m_tItem(i).sCaption), -1, _
            DT_CENTER Or DT_WORDBREAK, _
            IIf(m_tItem(i).bEnabled, 0, DTT_GRAYED), _
            tContentR
      
         If (iStateId = TS_DISABLED) Then
            CloseThemeData hTheme
            hTheme = OpenThemeData(UserControl.hwnd,
             StrPtr(UXTHEMETOOLBARCLASS))
         End If
      
      Next i
      
      CloseThemeData hTheme
      
   Else
      
      SetBkMode m_cMemDC.hDC, TRANSPARENT
      For i = 1 To m_lItemCount
         LSet tItemR = tR
         tItemR.top = m_tItem(i).yStart
         tItemR.bottom = tItemR.top + m_tItem(i).yExtent
         OffsetRect tItemR, 0, -lOffset
         If (m_tItem(i).bEnabled) Then
            If (m_tItem(i).bMouseDown) Then
               If (m_tItem(i).bMouseOver) Then
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_HOTCHECKED
                  Else
                     iStateId = TS_PRESSED
                  End If
               Else
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_CHECKED
                  Else
                     iStateId = TS_HOT
                  End If
               End If
            Else
               If (m_tItem(i).bMouseOver) Then
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_HOTCHECKED
                  Else
                     iStateId = TS_HOT
                  End If
               Else
                  If (m_tItem(i).bSelected) Then
                     iStateId = TS_CHECKED
                  Else
                     iStateId = TS_NORMAL
                  End If
               End If
            End If
         Else
            iStateId = TS_DISABLED
         End If
         
         ' Draw background to item (if necessary);
         If (iStateId = TS_CHECKED) Then
            hBr = GetSysColorBrush(vbButtonFace And &H1F&)
            FillRect m_cMemDC.hDC, tItemR, hBr
            DeleteObject hBr
         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
         ElseIf (iStateId = TS_HOT) Then
            DrawEdgeAPI m_cMemDC.hDC, tItemR, BDR_RAISED, BF_RECT Or BF_SOFT
         ElseIf (iStateId = TS_PRESSED) Then
            DrawEdgeAPI m_cMemDC.hDC, tItemR, BDR_SUNKEN, BF_RECT Or BF_SOFT
         End If
                  
         LSet tContentR = tItemR
         InflateRect tContentR, -2, -2
                  
         LSet tIconR = tItemR
         tIconR.left = tContentR.left + (tContentR.right - tContentR.left -
          m_lIconSize) \ 2
         tIconR.right = tIconR.left + m_lIconSize
         tIconR.top = tIconR.top + 4
         tIconR.bottom = tIconR.top + m_lIconSize
         If (iStateId = TS_PRESSED) Then
            OffsetRect tIconR, 1, 1
         End If
         
         If (m_tItem(i).bEnabled) Then
            ImageListDrawIcon m_ptrVB6ImageList, m_cMemDC.hDC, m_hIml, _
               m_tItem(i).iIconIndex, _
               tIconR.left + (tIconR.right - tIconR.left - m_lIconSize) \ 2, _
               tIconR.top + 4
         Else
            ImageListDrawIconDisabled m_ptrVB6ImageList, m_cMemDC.hDC, m_hIml, _
               m_tItem(i).iIconIndex, _
               tIconR.left, _
               tIconR.top, _
               m_lIconSize
         End If
         
         tContentR.top = tContentR.top + 4 + m_lIconSize
         InflateRect tContentR, -6, 0
         If (iStateId = TS_PRESSED) Then
            OffsetRect tContentR, 1, 1
         End If
                  
         If (iStateId = TS_DISABLED) Then
            SetTextColor m_cMemDC.hDC, TranslateColor(vb3DHighlight)
            OffsetRect tContentR, 1, 1
         Else
            SetTextColor m_cMemDC.hDC, TranslateColor(UserControl.ForeColor)
         End If
         DrawText m_cMemDC.hDC, _
            m_tItem(i).sCaption, -1, _
            tContentR, _
            DT_CENTER Or DT_WORDBREAK
         If (iStateId = TS_DISABLED) Then
            SetTextColor m_cMemDC.hDC, TranslateColor(vbButtonShadow)
            OffsetRect tContentR, -1, -1
            DrawText m_cMemDC.hDC, _
               m_tItem(i).sCaption, -1, _
               tContentR, _
               DT_CENTER Or DT_WORDBREAK
         End If
            
      Next i
      
   End If
   
   SelectObject m_cMemDC.hDC, hFontOld
   
End Sub

Private Sub pPaint()
Dim tR As RECT
   
   ' Prepare memory DC:
   GetClientRect UserControl.hwnd, tR
   m_cMemDC.Width = m_lButtonWidth
   m_cMemDC.Height = tR.bottom - tR.top
   
   ' Clear the background:
   pClearBackground tR
   
   ' Draw all items in turn:
   tR.left = tR.left + 3
   tR.right = tR.left + m_lButtonWidth - 6

   pDrawItems tR
   
   ' Swap memory DC into UserControl:
   m_cMemDC.Draw UserControl.hDC, 0, 0, m_lButtonWidth, tR.bottom - tR.top

End Sub

Private Function plHitTest() As Long
   Dim tP As POINTAPI
   GetCursorPos tP
   ScreenToClient UserControl.hwnd, tP
   plHitTest = plHitTestPoint(tP.x, tP.y)
End Function

Private Function plHitTestPoint(ByVal x As Long, ByVal y As Long) As Long
Dim i As Long
Dim lOffset As Long
Dim tR As RECT

   GetClientRect UserControl.hwnd, tR
   If Not (PtInRect(tR, x, y) = 0) Then
      If (x >= 3) And (x <= m_lButtonWidth - 6) Then
         If Not (m_cScroll Is Nothing) Then
            If (m_cScroll.Visible(efsVertical)) Then
               lOffset = m_cScroll.Value(efsVertical)
            End If
         End If
         For i = 1 To m_lItemCount
            If (y >= m_tItem(i).yStart - lOffset) Then
               If (y <= m_tItem(i).yStart + m_tItem(i).yExtent - lOffset) Then
                  plHitTestPoint = i
                  Exit For
               End If
            End If
         Next i
      End If
   End If
End Function

Private Function plSelectNext( _
      ByVal lCurrent As Long, _
      ByVal lDir As Long _
   )
Dim bFound As Boolean
Dim lNewIndex As Long
Dim lLastChecked As Long
   
   lLastChecked = lCurrent
   Do While Not (bFound)
      lNewIndex = lLastChecked + lDir
      
      If (lNewIndex < 1) Or (lNewIndex > m_lItemCount) Then
         If (Abs(lDir) > 1) Then
            ' equivalent to hitting Home or End:
            If (Sgn(lDir) = 1) Then
               ' End
               lNewIndex = m_lItemCount
               Do While Not bFound
                  If (m_tItem(lNewIndex).bEnabled) Then
                     bFound = True
                  Else
                     lNewIndex = lNewIndex - 1
                     If (lNewIndex < 1) Then
                        bFound = True
                     End If
                  End If
               Loop
            Else
               ' Home
               lNewIndex = 1
               Do While Not bFound
                  If (m_tItem(lNewIndex).bEnabled) Then
                     bFound = True
                  Else
                     lNewIndex = lNewIndex + 1
                     If (lNewIndex > m_lItemCount) Then
                        bFound = True
                     End If
                  End If
               Loop
            End If
         End If
         bFound = True
      Else
         lLastChecked = lNewIndex
         If (m_tItem(lNewIndex).bEnabled) Then
            bFound = True
         End If
         lDir = Sgn(lDir)
      End If
   Loop
   plSelectNext = lNewIndex
   
End Function

Private Sub pShortcutSelect(ByVal sKey As String)
Dim j As Long
   For j = 1 To m_lItemCount
      If (InStr(UCase(m_tItem(j).sCaption), "&" & sKey) > 0) Then
         ' SPM: Bug fix 2003-06-07: Don't allow a disabled item
         ' to be selected by its mnemonic:
         If (ItemEnabled(j)) Then
            ItemSelected(j) = True
            pEnsureVisible j
            RaiseEvent ItemClick(j)
         End If
         Exit For
      End If
   Next j
End Sub

Private Sub ImageListDrawIcon( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hDC As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        Optional ByVal bSelected As Boolean = False, _
        Optional ByVal bBlend25 As Boolean = False _
    )
Dim lFlags As Long
Dim lR As Long

    lFlags = ILD_TRANSPARENT
    If (bSelected) Then
        lFlags = lFlags Or ILD_SELECTED
    End If
    If (bBlend25) Then
        lFlags = lFlags Or ILD_BLEND25
    End If
    If (ptrVb6ImageList <> 0) Then
        Dim o As Object
        On Error Resume Next
        Set o = ObjectFromPtr(ptrVb6ImageList)
        If Not (o Is Nothing) Then
            o.ListImages(iIconIndex + 1).Draw hDC, lX * Screen.TwipsPerPixelX,
             lY * Screen.TwipsPerPixelY, lFlags
        End If
        On Error GoTo 0
    Else
        lR = ImageList_Draw( _
                hIml, _
                iIconIndex, _
                hDC, _
                lX, _
                lY, _
                lFlags)
        If (lR = 0) Then
            Debug.Print "Failed to draw Image: " & iIconIndex & " onto hDC " &
             hDC, "ImageListDrawIcon"
        End If
    End If
End Sub
Private Sub ImageListDrawIconDisabled( _
        ByVal ptrVb6ImageList As Long, _
        ByVal hDC As Long, _
        ByVal hIml As Long, _
        ByVal iIconIndex As Long, _
        ByVal lX As Long, _
        ByVal lY As Long, _
        ByVal lSize As Long, _
        Optional ByVal asShadow As Boolean _
    )
Dim lR As Long
Dim hIcon As Long
Dim idp As IMAGELISTDRAWPARAMS

   'If (ptrVb6ImageList = 0) And (m_bIsXp) Then
   '   idp.cbSize = Len(idp)
   '   idp.hIml = m_hIml
   '   idp.hdcDst = hdc
   '   idp.rgbBk = -1
   '   idp.fState = ILD_PRESERVEALPHA Or ILD_IMAGE
   '   idp.x = lX
   '   idp.y = lY
   '   idp.i = iIconIndex
   '   idp.fState = ILS_SATURATE
   '   idp.Frame = 128
   '   lR = ImageList_DrawIndirect(idp)
   '   Debug.Print lR
   'Else

      hIcon = 0
      If (ptrVb6ImageList <> 0) Then
         Dim o As Object
         On Error Resume Next
         Set o = ObjectFromPtr(ptrVb6ImageList)
         If Not (o Is Nothing) Then
            
            Dim lhDCDisp As Long
            Dim lhDC As Long
            Dim lhBmp As Long
            Dim lhBmpOld As Long
            Dim lhIml As Long
                     
            lhDCDisp = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
            lhDC = CreateCompatibleDC(lhDCDisp)
            lhBmp = CreateCompatibleBitmap(lhDCDisp, o.ImageWidth,
             o.ImageHeight)
            DeleteDC lhDCDisp
            lhBmpOld = SelectObject(lhDC, lhBmp)
            o.ListImages.Item(iIconIndex + 1).Draw lhDC, 0, 0, 0
            SelectObject lhDC, lhBmpOld
            DeleteDC lhDC
            lhIml = ImageList_Create(o.ImageWidth, o.ImageHeight, ILC_MASK Or
             ILC_COLOR32, 1, 1)
            ImageList_AddMasked lhIml, lhBmp, TranslateColor(o.BackColor)
            DeleteObject lhBmp
            hIcon = ImageList_GetIcon(lhIml, 0, 0)
            ImageList_Destroy lhIml
            
         End If
         On Error GoTo 0
      Else
         hIcon = ImageList_GetIcon(hIml, iIconIndex, 0)
      End If
      If (hIcon <> 0) Then
         If (asShadow) Then
            Dim hBr As Long
            hBr = GetSysColorBrush(vb3DShadow And &H1F)
            lR = DrawState(hDC, hBr, 0, hIcon, 0, lX, lY, lSize, lSize,
             DST_ICON Or DSS_MONO)
            DeleteObject hBr
         Else
            lR = DrawState(hDC, 0, 0, hIcon, 0, lX, lY, lSize, lSize, DST_ICON
             Or DSS_DISABLED)
         End If
         DestroyIcon hIcon
      End If
   'End If
End Sub
Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim oTemp As Object
   ' Turn the pointer into an illegal, uncounted interface
   CopyMemory oTemp, lPtr, 4
   ' Do NOT hit the End button here! You will crash!
   ' Assign to legal reference
   Set ObjectFromPtr = oTemp
   ' Still do NOT hit the End button here! You will still crash!
   ' Destroy the illegal reference
   CopyMemory oTemp, 0&, 4
   ' OK, hit the End button if you must--you'll probably still crash,
   ' but it will be because of the subclass, not the uncounted reference
End Property

' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    If OleTranslateColor(clr, hPal, TranslateColor) Then
        TranslateColor = -1
    End If
End Function

Private Sub pInitialise()
   If (UserControl.Ambient.UserMode) Then
      m_bRunTime = True
      Set m_cScroll = New pcScrollBars
      m_cScroll.Create UserControl.hwnd
      Set m_tmr = New CTimer
   End If
End Sub
Private Sub pTerminate()
   If Not m_tmr Is Nothing Then
      m_tmr.Interval = 0
      Set m_tmr = Nothing
   End If
   If Not m_cScroll Is Nothing Then
      Set m_cScroll = Nothing
   End If
   Set m_cMemDC = Nothing
End Sub

Private Sub pUpdateMnemonics()
   If (UserControl.AccessKeys = "") Then
      UserControl.AccessKeys = " "
   Else
      UserControl.AccessKeys = ""
   End If
   UserControl.Refresh
End Sub

Friend Function GetControlInfo(pCI As CONTROLINFO) As Long
   
   pCI.cb = LenB(pCI)
   pCI.cAccel = m_cMnemonics.Count
   pCI.hAccel = m_cMnemonics.hAccel
   pCI.dwFlags = 0
   
End Function
Friend Function OnMnemonic(pMsg As MSG) As Long
Dim i As Long
   
   If (pMsg.Message = WM_SYSCHAR Or pMsg.Message = WM_SYSKEYDOWN) Then
      For i = 1 To m_cMnemonics.Count
         If (pMsg.wParam = m_cMnemonics.VirtKey(i)) Then
            ' Got a mnemonic:
            pShortcutSelect m_cMnemonics.Key(i)
            Exit For
         End If
      Next i
   End If
   
End Function


Private Sub m_cScroll_Change(eBar As EFSScrollBarConstants)
   '
   pPaint
   '
End Sub

Private Sub m_cScroll_Scroll(eBar As EFSScrollBarConstants)
   '
   pPaint
   '
End Sub

Private Sub m_cScroll_ScrollClick(eBar As EFSScrollBarConstants, eButton As
 MouseButtonConstants)
   If Not (m_bFocus) Then
      UserControl.SetFocus
   End If
End Sub

Private Sub m_tmr_ThatTime()
Dim i As Long
Dim lIndex As Long
   For i = 1 To m_lItemCount
      If (m_tItem(i).bMouseDown) Then
         Exit Sub
      Else
         If (m_tItem(i).bMouseOver) Then
            lIndex = i
         End If
      End If
   Next i
   
   If (lIndex > 0) Then
      If (plHitTest() = 0) Then
         pSetToolTip ""
         m_tItem(lIndex).bMouseOver = False
         m_tmr.Interval = 0
         pPaint
      End If
   Else
      m_tmr.Interval = 0
      pSetToolTip ""
   End If
End Sub

Private Sub UserControl_GotFocus()
   m_bFocus = True
' Deprecated - replaced with IOleControl implementation
'Dim sKeys As String
'Dim i As Long
'Dim sKey As String
'   If (GetAsyncKeyState(vbKeyMenu) And &H8000&) = &H8000& Then
'      sKeys = UserControl.AccessKeys
'      For i = 1 To Len(sKeys)
'         sKey = Mid$(sKeys, i, 1)
'         If (GetAsyncKeyState(Asc(sKey)) And &H8000&) = &H8000& Then
'            pShortcutSelect sKey
'            Exit For
'         End If
'      Next i
'   End If
End Sub

Private Sub UserControl_Initialize()
   '
   'MsgBox "UC:Init"
   
   ' Get the IOLEControl interface of the control
   Dim IOleCtl As IOleControl
   Set IOleCtl = Me
   ' Replace IOLEControl methods:
   m_ptrGetControlInfoOrig = ReplaceVTableEntry( _
      ObjPtr(IOleCtl), _
      IDX_GetControlInfo, _
      AddressOf mIOleControl.IOleControl_GetControlInfo, _
      ObjPtr(Me) _
      )
   m_ptrOnMnemonicOrg = ReplaceVTableEntry( _
      ObjPtr(IOleCtl), _
      IDX_OnMnemonic, _
      AddressOf mIOleControl.IOleControl_OnMnemonic, _
      ObjPtr(Me) _
      )

   ' Create object to manage Mnemonics for this control:
   Set m_cMnemonics = New pcMnemonics
      
   ' Set up version information:
   Dim lMajor As Long
   Dim lMinor As Long
   
   GetWindowsVersion lMajor, lMinor, , , m_bIsNt
   If (lMajor > 5) Then
      m_bIsXp = True
   ElseIf (lMajor = 5) And (lMinor >= 1) Then
      m_bIsXp = True
   End If
   
   ' General helper objects:
   Set m_cMemDC = New pcMemDC
   m_oBackColor = -1
   m_oForeColor = -1
   m_lButtonWidth = 84
   '
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print "KeyDown"
Dim sKeys As String
Dim sKey As String
Dim i As Long
Dim j As Long
Dim eKeyCode As KeyCodeConstants
Dim eShift As ShiftConstants
   
   eKeyCode = KeyCode
   eShift = Shift
   
   RaiseEvent KeyDown(eKeyCode, eShift)
   
   If ((Shift And vbAltMask) = vbAltMask) Then
' Deprecated - replaced by IOleControl OnMnemonic processing
'      sKeys = UserControl.AccessKeys
'      For i = 1 To Len(sKeys)
'         sKey = Mid$(sKeys, i, 1)
'         If (Asc(UCase(sKey)) = KeyCode) Or (Asc(LCase(sKey)) = KeyCode) Then
'            Exit For
'         End If
'      Next i
   Else
      If (m_lItemCount > 0) Then
         Dim lNewIndex As Long
         Dim lCurrentIndex As Long
         Dim lMouseOverIndex As Long
         Dim bFound As Boolean
         
         For i = 1 To m_lItemCount
            If (m_tItem(i).bMouseOver) Then
               lMouseOverIndex = i
            End If
            If (m_tItem(i).bSelected) Then
               lCurrentIndex = i
            End If
         Next i
         
         If (lMouseOverIndex > 0) Then
            lCurrentIndex = lMouseOverIndex
         End If
         
         Select Case KeyCode
         Case vbKeyUp
            lNewIndex = plSelectNext(lCurrentIndex, -1)
         Case vbKeyDown
            lNewIndex = plSelectNext(lCurrentIndex, 1)
         Case vbKeyPageUp
            lNewIndex = plSelectNext(lCurrentIndex, -4)
         Case vbKeyPageDown
            lNewIndex = plSelectNext(lCurrentIndex, 4)
         Case vbKeyHome
            lNewIndex = 1
            Do While Not bFound
               If (m_tItem(lNewIndex).bEnabled) Then
                  bFound = True
               Else
                  lNewIndex = lNewIndex + 1
                  If (lNewIndex > m_lItemCount) Then
                     bFound = True
                  End If
               End If
            Loop
         Case vbKeyEnd
            lNewIndex = m_lItemCount
            Do While Not bFound
               If (m_tItem(lNewIndex).bEnabled) Then
                  bFound = True
               Else
                  lNewIndex = lNewIndex - 1
                  If (lNewIndex < 1) Then
                     bFound = True
                  End If
               End If
            Loop
         Case vbKeyReturn
            If (lMouseOverIndex > 0) Then
               ItemSelected(lMouseOverIndex) = True
               m_tItem(lMouseOverIndex).bMouseOver = False
               pEnsureVisible lMouseOverIndex
               RaiseEvent ItemClick(lMouseOverIndex)
            End If
         Case Else
            pShortcutSelect Chr$(KeyCode)
         End Select
         
         If (lNewIndex <> lCurrentIndex) And (lNewIndex > 0) And (lNewIndex <=
          m_lItemCount) Then
            For i = 1 To m_lItemCount
               If (i = lNewIndex) Then
                  m_tItem(i).bMouseOver = True
               Else
                  m_tItem(i).bMouseOver = False
               End If
            Next i
            pEnsureVisible lNewIndex
            pPaint
         End If
         
      End If
   End If
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
Debug.Print "KeyPress"
   RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
Dim eKeyCode As KeyCodeConstants
Dim eShift As ShiftConstants
   
   eKeyCode = KeyCode
   eShift = Shift

   RaiseEvent KeyUp(eKeyCode, eShift)
End Sub

Private Sub UserControl_LostFocus()
Dim i As Long
Dim bUpdate As Boolean
   For i = 1 To m_lItemCount
      If (m_tItem(i).bMouseOver) Then
         m_tItem(i).bMouseOver = False
         bUpdate = True
      End If
   Next i
   If (bUpdate) Then
      pPaint
   End If
   m_bFocus = False
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   '
Dim eButton As MouseButtonConstants
Dim eShift As ShiftConstants

   RaiseEvent MouseDown(eButton, eShift, x, y)
   
   m_tmr.Interval = 0
   Dim lIndex As Long
   
   lIndex = plHitTest()
   If (lIndex > 0) Then
      If (Button = vbLeftButton) Then
         m_tItem(lIndex).bMouseDown = True
         pPaint
      ElseIf (Button = vbRightButton) Then
         RaiseEvent ItemRightClick(lIndex, x, y)
      End If
   ElseIf (Button = vbRightButton) Then
      RaiseEvent BarRightClick(x, y)
   End If
   '
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   '
Dim eButton As MouseButtonConstants
Dim eShift As ShiftConstants
   
   RaiseEvent MouseMove(eButton, eShift, x, y)
   
   Dim lIndex As Long
   Dim i As Long
   Dim bChange As Boolean
   
   lIndex = plHitTest()
   For i = 1 To m_lItemCount
      If (i = lIndex) Then
         If Not (m_tItem(i).bMouseOver) Then
            pSetToolTip m_tItem(i).sToolTip
            m_tItem(i).bMouseOver = True
            bChange = True
         End If
      Else
         If (m_tItem(i).bMouseOver) Then
            m_tItem(i).bMouseOver = False
            bChange = True
         End If
      End If
   Next i
   If (lIndex = 0) Then
      pSetToolTip ""
   End If
   
   If (bChange) Then
      pPaint
   End If
   
   If (Button = 0) Then
      If (m_tmr.Interval = 0) Then
         m_tmr.Interval = 50
      End If
   Else
      If (m_tmr.Interval > 0) Then
         m_tmr.Interval = 0
      End If
   End If
   '
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As
 Single, y As Single)
   '
Dim eButton As MouseButtonConstants
Dim eShift As ShiftConstants
   
   RaiseEvent MouseUp(eButton, eShift, x, y)
   
   If (Button = vbLeftButton) Then
      Dim i As Long
      Dim bChange As Boolean
      For i = 1 To m_lItemCount
         If (m_tItem(i).bMouseDown) Then
            If (plHitTest() = i) Then
               If (m_tItem(i).bEnabled) Then
                  ' Click
                  m_tItem(i).bMouseDown = False
                  ItemSelected(i) = True
                  pEnsureVisible i
                  RaiseEvent ItemClick(i)
               Else
                  m_tItem(i).bMouseDown = False
               End If
            Else
               ' no click
               m_tItem(i).bMouseDown = False
               bChange = True
            End If
         End If
      Next i
      If (bChange) Then
         pPaint
      End If
   End If
   '
End Sub

Private Sub UserControl_Paint()
   '
   pPaint
   '
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   BackColor = PropBag.ReadProperty("BackColor", -1)
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.SIZE = 8
   Set Font = PropBag.ReadProperty("Font", sFnt)
   m_lButtonWidth = PropBag.ReadProperty("ButtonWidth", 96)
   ScaleMode = PropBag.ReadProperty("ScaleMode", vbTwips)
   
   pInitialise
   '
End Sub

Private Sub UserControl_Resize()
   '
   pResize
   RaiseEvent Resize
   '
End Sub

Private Sub UserControl_Show()
   '
   pResize
   '
End Sub

Private Sub UserControl_Terminate()
   '
   'MsgBox "UC:Term"
   pTerminate
      
   ' Clear up IOLEControl interface of the control
   Dim IOleCtl As IOleControl
   Set IOleCtl = Me
   ' Restore IOleControl methods:
   ReplaceVTableEntry _
      ObjPtr(IOleCtl), _
      IDX_GetControlInfo, _
      m_ptrGetControlInfoOrig
   ReplaceVTableEntry _
      ObjPtr(IOleCtl), _
      IDX_OnMnemonic, _
      m_ptrOnMnemonicOrg
   '
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "BackColor", BackColor, -1
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.SIZE = 8
   PropBag.WriteProperty "Font", Font, sFnt
   PropBag.WriteProperty "ButtonWidth", m_lButtonWidth, 96
   PropBag.WriteProperty "ScaleMode", ScaleMode, vbTwips
   '
End Sub