vbAccelerator - Contents of code file: vbalExplorerBarCtl.ctl

VERSION 5.00
Begin VB.UserControl vbalExplorerBarCtl 
   Alignable       =   -1  'True
   AutoRedraw      =   -1  'True
   ClientHeight    =   6840
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4050
   ControlContainer=   -1  'True
   ScaleHeight     =   6840
   ScaleWidth      =   4050
   ToolboxBitmap   =   "vbalExplorerBarCtl.ctx":0000
End
Attribute VB_Name = "vbalExplorerBarCtl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

' ===========================================================================
' Name:     vbalExplorerBarCtl
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     10 June 2003
'
' Dependencies:
' Runtime:     SSUBTMR.DLL
' Designtime:  vbaCom.TLB, OLEGUIDS.TLB
'
' ---------------------------------------------------------------------------
' Copyright  2003 Steve McMahon (steve@vbaccelerator.com) for
' vbAccelerator Ltd.
'
' Visit vbAccelerator - free, advanced source code for VB programmers.
'     http://vbaccelerator.com
' ---------------------------------------------------------------------------
'
' Description:
' RELEASE 1
' Implementation of XP-style explorer bar in VB.
' Best with Win98/2000 or above and > 256 colour display.
'
' 2003-07-05
'  * Fixed numerous GDI leaks under Win98/ME.
'  * Mouse wheel support for scrolling.
'  * Unicode text support under NT.
'  * Controls are now contained within the bar.
'  * Contained controls resized horizontally.
'  * Headers for non-expandable items draw correctly.
'
' FREE SOURCE CODE! - ENJOY.
' - Please report bugs to the author for incorporation into future releases
' - See licence
' ===========================================================================

' ---------------------------------------------------------------------------
' 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
'   (/index.html)."
'
' 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.
'
' ---------------------------------------------------------------------------


'
' Produced under the influence of
'  - Autechre - 7.30 Draft <--
'  - Julie A
'  - Budweiser Budvar
'  - Jeffery Steingarten - The Man Who Ate Anything.
'  - Makers Mark
'  - uZiq - Bilious Path
'  - Squarepusher - Do You Know Squarepusher
'  - Akufen, Venetian Snares, Junior Senior
'  - Samsung 19" TFT, Sony 52x24x52 CD
'  - BitTorrent
'  - Steady B, Tricky Tee, Mantronix
'  - Les Trois Garcons, Loungelover..
'
' Deterred by
'  - Shellstyle.dll.  What's that about?  Could it be that the theme DLL
'    and API is just a hopeless hack that needs a pile of work?
'  - Job. It was meant to be an XML job.  But yet again is actually
'    a Java job (I'm rubbish at Java.  I'm not that great at XML either
'    for that matter.)
'  - Kids stole my computer.  Brick through window, what can you do - was
'    the only computer I ever owned that worked properly too...
'

' Types required for API
Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type SIZEAPI
   cX As Long
   cY As Long
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type

' General Windows API
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As
 Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal
 hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal
 hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect
 As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect
 As RECT) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA"
 (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As
 Long
' Missing from VB API declarations:
Private Const DONT_RESOLVE_DLL_REFERENCES = &H1&
Private Const LOAD_LIBRARY_AS_DATAFILE = &H2&
Private Const LOAD_WITH_ALTERED_SEARCH_PATH = &H8&
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long)
 As Long
Private Declare Function LoadImageLong Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As Long, ByVal uType As Long, ByVal cX As Long,
 ByVal cY As Long, ByVal uFlags As Long) As Long
Private Declare Function LoadImageString Lib "user32" Alias "LoadImageA" (ByVal
 hInst As Long, ByVal lpsz As String, ByVal uType As Long, ByVal cX As Long,
 ByVal cY As Long, ByVal uFlags As Long) As Long
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_CREATEDIBSECTION = &H2000
Private Const LR_COPYFROMRESOURCE = &H4000
Private Const LR_SHARED = &H8000&
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) 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 VkKeyScan Lib "user32" Alias "VkKeyScanA" (ByVal cChar
 As Byte) As Integer
Private Declare Function VkKeyScanW Lib "user32" (ByVal cChar As Integer) As
 Integer
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As
 Integer
Private Const WM_SYSCHAR& = &H106&
Private Const WM_SYSKEYDOWN& = &H104&
Private Const WM_KEYDOWN = &H100&
Private Const WM_KEYUP = &H101&
Private Const WM_SETFOCUS = &H7&
Private Const WM_SETTINGCHANGE = &H1A&

' Drawing API:
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 Const COLOR_GRADIENTACTIVECAPTION = 27
Private Const COLOR_GRADIENTINACTIVECAPTION = 28
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
 hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
 Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc
 As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function GetPixelAPI Lib "gdi32" Alias "GetPixel" (ByVal hdc As
 Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y 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 SetTextColor Lib "gdi32" (ByVal hdc As Long, 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
' BlendOp:
Private Const AC_SRC_OVER = &H0
' AlphaFormat:
Private Const AC_SRC_ALPHA = &H1
Private Declare Function AlphaBlend Lib "msimg32.dll" ( _
     ByVal hdcDest As Long, _
     ByVal nXOriginDest As Long, _
     ByVal nYOriginDest As Long, _
     ByVal nWidthDest As Long, _
     ByVal nHeightDest As Long, _
     ByVal hdcSrc As Long, _
     ByVal nXOriginSrc As Long, _
     ByVal nYOriginSrc As Long, _
     ByVal nWidthSrc As Long, _
     ByVal nHeightSrc As Long, _
     ByVal lBlendFunction As Long _
   ) As Long
Private Declare Function TransparentBlt Lib "msimg32.dll" ( _
   ByVal hdcDest As Long, _
   ByVal nXOriginDest As Long, _
   ByVal nYOriginDest As Long, _
   ByVal nWidthDest As Long, _
   ByVal hHeightDest As Long, _
   ByVal hdcSrc As Long, _
   ByVal nXOriginSrc As Long, _
   ByVal nYOriginSrc As Long, _
   ByVal nWidthSrc As Long, _
   ByVal nHeightSrc As Long, _
   ByVal crTransparent As Long _
   ) As Long

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

' DrawEdge:
Private Enum DrawEdgeBorderFlags
   BDR_RAISEDOUTER = &H1
   BDR_SUNKENOUTER = &H2
   BDR_RAISEDINNER = &H4
   BDR_SUNKENINNER = &H8

   BDR_OUTER = &H3
   BDR_INNER = &HC
   BDR_RAISED = &H5
   BDR_SUNKEN = &HA

   EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
   EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
   EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
   EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
End Enum

Private Enum DrawEdgeBorderPartFlags
   BF_LEFT = &H1
   BF_TOP = &H2
   BF_RIGHT = &H4
   BF_BOTTOM = &H8

   BF_TOPLEFT = (BF_TOP Or BF_LEFT)
   BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
   BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
   BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
   BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
End Enum

' ImageList API:
Private Declare Function ImageList_GetIconSize Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        cX As Long, cY As Long _
    ) 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
' Create a new icon based on an image list icon:
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_GetImageCount Lib "comctl32.dll" ( _
        ByVal hIml 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_NORMAL = 0
Private Const ILD_TRANSPARENT = 1
Private Const ILD_BLEND25 = 2
Private Const ILD_SELECTED = 4
Private Const ILD_FOCUS = 4
Private Const ILD_MASK = &H10&
Private Const ILD_IMAGE = &H20&
Private Const ILD_ROP = &H40&
Private Const ILD_OVERLAYMASK = 3840
Private Const ILC_COLOR = &H0
Private Const ILC_COLOR32 = &H20
Private Const ILC_MASK = &H1&


' UXTHEME API:
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 hdc As Long, _
    ByVal iPartId As Long, _
    ByVal iStateId As Long, _
    pRect As RECT, _
    pClipRect As RECT) As Long
Private Declare Function GetCurrentThemeName Lib "uxtheme.dll" ( _
    ByVal pszThemeFileName As Long, _
    ByVal dwMaxNameChars As Long, _
    ByVal pszColorBuff As Long, _
    ByVal cchMaxColorChars As Long, _
    ByVal pszSizeBuff As Long, _
    ByVal cchMaxSizeChars As Long _
   ) As Long
Private Declare Function GetThemeFilename Lib "uxtheme.dll" _
   (ByVal hTheme As Long, _
    ByVal iPartId As Long, _
    ByVal iStateId As Long, _
    ByVal iPropId As Long, _
    pszThemeFileName As Long, _
    ByVal cchMaxBuffChars 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 SIZEAPI _
   ) 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 dwTextFlags As Long, _
    ByVal dwTextFlags2 As Long, _
    pRect As RECT _
   ) As Long

Private Enum EExplorerBarParts
   EBP_HEADERBACKGROUND = 1
   EBP_HEADERCLOSE
   EBP_HEADERPIN
   EBP_IEBARMENU
   EBP_NORMALGROUPBACKGROUND
   EBP_NORMALGROUPCOLLAPSE
   EBP_NORMALGROUPEXPAND
   EBP_NORMALGROUPHEAD
   EBP_SPECIALGROUPBACKGROUND
   EBP_SPECIALGROUPCOLLAPSE
   EBP_SPECIALGROUPEXPAND
   EBP_SPECIALGROUPHEAD
End Enum
Private Const TS_MIN = 0
Private Const TS_TRUE = 1
Private Const TS_DRAW = 2


' #REGION Implementation

' Enumerations
Public Enum EExplorerBarItemTypes
   eItemLink
   eItemText
   eItemControlPlaceHolder
End Enum

Public Enum EExplorerBarStyles
   eDefaultStyle
   eSearchStyle
End Enum

Public Enum EExplorerBarStates
   eBarCollapsed
   eBarExpanded
End Enum

Public Enum EExplorerBarWatermarkModes
   eWaterMarkColourise
   eWaterMarkDirect
End Enum

Public Enum EExplorerBarWatermarkHAlign
   eWaterMarkAlignLeft = 0
   eWaterMarkAlignHCentre = 1
   eWaterMarkAlignRight = 2
End Enum

Public Enum EExplorerBarWatermarkVAlign
   eWaterMarkAlignTop = 0
   eWaterMarkAlignVCentre = 1
   eWaterMarkAlignBottom = 1
End Enum

' Events:
Public Event BarRightClick(bar As cExplorerBar)
Attribute BarRightClick.VB_Description = "Raised when the user right clicks a
 bar."
Public Event BarClick(bar As cExplorerBar)
Attribute BarClick.VB_Description = "Raised after a bar has been clicked, and
 the bar's state has changed."
Public Event ItemRightClick(itm As cExplorerBarItem)
Attribute ItemRightClick.VB_Description = "Raised when a user right clicks on
 an item in the control."
Public Event ItemClick(itm As cExplorerBarItem)
Attribute ItemClick.VB_Description = "Raised when an item is clicked."
Public Event Highlight(bar As cExplorerBar, itm As cExplorerBarItem)
Attribute Highlight.VB_Description = "Raised when an item or bar is highlighted
 by the user moving the mouse over it."
Public Event SettingChange()

' Bars is a collection of pcExplorerBars keyed on ID
' in the order the bars appear in the control:
Private m_colBars As Collection
' A collection of the Ids keyed by the item's Key:
Private m_colBarKeys As Collection

' All the items for all bars keyed by ID:
Private m_colItems As Collection

' Image List
Private m_hIml As Long
Private m_ptrVB6ImageList As Long
Private m_lIconSize As Long
' Bar Title Image List
Private m_hImlBarTitle As Long
Private m_ptrVB6ImageListBarTitle As Long
Private m_lBarTitleIconSize As Long

' Selections
Private m_lIdSelBar As Long
Private m_lIdSelItem As Long

' Explorer Style Rendering Control:
Private m_bUseExplorerTransitionStyle As Boolean
Private m_bUseExplorerTheme As Boolean
Private m_hDib(0 To 10) As Long
Private m_hDC As Long
Private m_lThemePanelColor As Long

' Non-Explorer Style Appearance:
Private m_oBackColorStart As OLE_COLOR
Private m_oBackColorEnd As OLE_COLOR
Private m_hFntTitle As Long

' General sizing and metrics:
Private m_lBarSpacing As Long
Private m_lItemSpacing As Long
Private m_lMargin As Long
Private m_cNCM As pcNCMetrics

' Helper classes:
Private WithEvents m_cScrollBar As pcScrollBars
Attribute m_cScrollBar.VB_VarHelpID = -1
Private m_cDibFade As pcAlphaDibSection
Private WithEvents m_tmr As CTimer
Attribute m_tmr.VB_VarHelpID = -1

' Control
Private m_bRunTime As Boolean
Private m_bFocus As Boolean
Private m_bShowFocusRect As Boolean
Private m_bHaveUsedKeys As Boolean
Private m_pcOver As pcExplorerBar
Private m_itmOver As pcExplorerBarItem
Private m_sToolTip As String
Private m_ePointer As MousePointerConstants
Private m_bRedraw As Boolean
Private m_eStyle As EExplorerBarStyles
Private m_lLastWidth As Long

' IOleControl support:
Private m_ptrGetControlInfoOrig As Long
Private m_ptrOnMnemonicOrig As Long
Private m_cMnemonics As pcMnemonics

' IOleInPlaceActiveObject support:
Private m_IPAOHookStruct As IPAOHookStruct
Private m_hWnd As Long
Private m_hWndContainer As Long

Implements ISubclass

Friend Sub fContainControl(ctlThis As Control)
   On Error Resume Next
   Set ctlThis.Container = UserControl.Extender
End Sub

Friend Sub fClearBars()
Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim iItem As Long
Dim ctl As Control

   ' Make any controls associated with this invisible:
   On Error Resume Next
   For Each pc In m_colBars
      For iItem = 1 To pc.ItemCount
         Set itm = pc.Item(iItem)
         If Not (itm.lPtrPanel = 0) Then
            Set ctl = ObjectFromPtr(itm.lPtrPanel)
            ctl.Visible = False
         End If
      Next iItem
   Next
   
   On Error GoTo 0
   Set m_colBars = New Collection
   Set m_colBarKeys = New Collection
   Set m_colItems = New Collection
   
   m_bHaveUsedKeys = False
   
   pMeasure
   pPaint
   UserControl.Refresh
   
End Sub
Friend Sub fTextChanged( _
      ByVal sOldCaption As String, _
      ByVal sNewCaption 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 Sub pUpdateMnemonics()
   If (UserControl.AccessKeys = "") Then
      UserControl.AccessKeys = " "
   Else
      UserControl.AccessKeys = ""
   End If
End Sub
Friend Property Get fBarIndex( _
      ByVal lId As Long _
   ) As Long
Dim i As Long
Dim pc As pcExplorerBar
   For i = 1 To m_colBars.Count
      Set pc = m_colBars(i)
      If (pc.ID = lId) Then
         fBarIndex = i
         Exit For
      End If
   Next i
End Property
Friend Property Let fBarIndex( _
      ByVal lId As Long, _
      ByVal lIndex As Long _
   )
Dim pcSwap As pcExplorerBar
Dim i As Long
Dim lIndexNow As Long
Dim colBarsTmp As New Collection
Dim colBarKeysTmp As New Collection

   If (lIndex < 0) Or (lIndex > m_colBars.Count) Then
      gErr 9, "vbalExplorerBarCtl"
   Else
      lIndexNow = fBarIndex(lId)
      If Not (lIndex = lIndexNow) Then
         If (lIndex > lIndexNow) Then
            ' Moving the bar down
            For i = 1 To m_colBars.Count
               If (i < lIndexNow) Then
                  colBarsTmp.Add m_colBars(i), "C:" & m_colBars(i).ID
                  colBarKeysTmp.Add m_colBars(i).ID, m_colBars(i).Key
               ElseIf (i < lIndex) Then
                  colBarsTmp.Add m_colBars(i + 1), "C:" & m_colBars(i + 1).ID
                  colBarKeysTmp.Add m_colBars(i + 1).ID, m_colBars(i + 1).Key
               ElseIf (i = lIndex) Then
                  colBarsTmp.Add m_colBars(lIndexNow), "C:" &
                   m_colBars(lIndexNow).ID
                  colBarKeysTmp.Add m_colBars(lIndexNow).ID,
                   m_colBars(lIndexNow).Key
                  Set pcSwap = m_colBars(lIndexNow)
               Else
                  colBarsTmp.Add m_colBars(i), "C:" & m_colBars(i).ID
                  colBarKeysTmp.Add m_colBars(i).ID, m_colBars(i).Key
               End If
            Next i
            Set m_colBars = colBarsTmp
            Set m_colBarKeys = colBarKeysTmp
         
         Else
            ' Moving the bar up
            For i = 1 To m_colBars.Count
               If (i < lIndex) Then
                  colBarsTmp.Add m_colBars(i), "C:" & m_colBars(i).ID
                  colBarKeysTmp.Add m_colBars(i).ID, m_colBars(i).Key
               ElseIf (i = lIndex) Then
                  colBarsTmp.Add m_colBars(lIndexNow), "C:" &
                   m_colBars(lIndexNow).ID
                  colBarKeysTmp.Add m_colBars(lIndexNow).ID,
                   m_colBars(lIndexNow).Key
                  Set pcSwap = m_colBars(lIndexNow)
               ElseIf (i <= lIndexNow) Then
                  colBarsTmp.Add m_colBars(i + 1), "C:" & m_colBars(i + 1).ID
                  colBarKeysTmp.Add m_colBars(i + 1).ID, m_colBars(i + 1).Key
               Else
                  colBarsTmp.Add m_colBars(i), "C:" & m_colBars(i).ID
                  colBarKeysTmp.Add m_colBars(i).ID, m_colBars(i).Key
               End If
            Next i
            Set m_colBars = colBarsTmp
            Set m_colBarKeys = colBarKeysTmp
            
         End If
         UserControl_Resize
         
         If (pcSwap.ID = m_lIdSelBar) Then
            fEnsureBarVisible pcSwap.ID
         End If
      End If
   End If
End Property
Friend Sub fBarChanged( _
      ByVal lId As Long, _
      ByVal bHeightChange As Boolean, _
      ByVal bColourChange As Boolean _
   )
Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim hTheme As Long
Dim tR As RECT
Dim iItem As Long
Dim lHeightOrigWith As Long
Dim lHeightOrigWithout As Long
   
   GetClientRect UserControl.hWnd, tR
   Set pc = m_colBars.Item("C:" & lId)
   
   If (bColourChange) Then
      If Not (m_bUseExplorerTheme) Then
         pbCreateBitmapWorkDC
         pbLoadShellStyleBitmaps
      End If
      pbColouriseWatermarks
   End If
   
   If (bHeightChange) Then
      fMeasureTitle lId
      
      lHeightOrigWith = pc.HeightWithScroll + pc.TitleHeightWithScroll
      lHeightOrigWithout = pc.HeightWithoutScroll + pc.TitleHeightWithoutScroll

      ' evaluate the new height of the item:
      For iItem = 1 To pc.ItemCount
         Set itm = pc.Item(iItem)
         fMeasureTitle pc.ID
         fMeasureItem pc.ID, itm.ID
      Next iItem
      pc.SetHeightFromItems
      
      ' set up a scroll to make this visible:
      If Not (lHeightOrigWith = pc.HeightWithScroll + pc.TitleHeightWithScroll)
       Or _
         Not (lHeightOrigWithout = pc.HeightWithoutScroll +
          pc.TitleHeightWithoutScroll) Then
         pMeasure
         pPaint
         UserControl.Refresh
      End If
      
   Else
      ' draw the item:
      hTheme = plGetTheme()
      pPaintBar pc, UserControl.hdc, hTheme, tR, True
      pPaintBorders UserControl.hdc, hTheme, tR
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
   End If
   
End Sub
   
Friend Sub fRemoveBar( _
      Index As Variant _
   )
   On Error Resume Next
   Dim lId As Long
   lId = m_colBarKeys(Index)
   If (Err.Number = 0) Then
   
      Dim pc As pcExplorerBar
      Dim itm As pcExplorerBarItem
      Dim iItem As Long
      Dim ctl As Control
   
      Set pc = m_colBars("C:" & lId)
      For iItem = 1 To pc.ItemCount
         Set itm = pc.Item(iItem)
         If Not (itm.lPtrPanel = 0) Then
            Set ctl = ObjectFromPtr(itm.lPtrPanel)
            ctl.Visible = False
         End If
      Next iItem
      
      On Error GoTo 0
      m_colBars.Remove "C:" & lId
      m_colBarKeys.Remove Index
      
      pMeasure
      pPaint
      UserControl.Refresh
      
   End If
End Sub
Friend Function fBarCount() As Long
   fBarCount = m_colBarKeys.Count
End Function

Friend Function fGetBar( _
      Index As Variant _
   ) As cExplorerBar
   On Error Resume Next
   
   Dim lId As Long
   lId = m_colBarKeys(Index)
   If (Err.Number = 0) Then
      On Error GoTo 0
      Dim c As New cExplorerBar
      c.fInit UserControl.hWnd, lId
      Set fGetBar = c
   End If
End Function

Friend Function fAddBar( _
      Optional Index As Variant, _
      Optional Key As Variant, _
      Optional Title As Variant _
   ) As cExplorerBar
   
   ' Verify the Index is ok:
   Dim lIndex As Long
   If Not IsMissing(Index) Then
      If (IsNumeric(Index)) Then
         On Error Resume Next
         lIndex = CLng(Index)
         If (Err.Number = 0) And (Index > 0) And (Index <= m_colBars.Count) Then
            On Error GoTo 0
            ' ok
         Else
            On Error GoTo 0
            gErr 9, "vbalExplorerBarCtl"
            Exit Function
         End If
      Else
         Dim i As Long
         For i = 1 To m_colBars.Count
            If (m_colBars(i).Key = Index) Then
               ' ok
               lIndex = i
               Exit For
            End If
         Next i
         If (lIndex = 0) Then
            ' Index is no good
            On Error GoTo 0
            gErr 9, "vbalExplorerBarCtl"
            Exit Function
         End If
      End If
   End If
   
   ' Verify if the Key is ok:
   On Error GoTo 0
   Dim sKey As String
   If Not IsMissing(Key) Then
      If IsNumeric(Key) Then
         gErr 13, "vbalExplorerBarCtl"
         Exit Function
      Else
         On Error Resume Next
         Dim lIdExisting As Long
         lIdExisting = m_colBarKeys(Key)
         If (Err.Number = 0) Then
            ' its no good
            On Error GoTo 0
            gErr 457, "vbalExplorerBarCtl"
         Else
            On Error GoTo 0
            sKey = Key
         End If
      End If
   End If
   
   ' Ok we're ready
   Dim lId As Long
   lId = NextId
   If (sKey = "") Then
      sKey = "C:" & lId
   End If
   
   ' Add or insert the item:
   Dim pc As New pcExplorerBar
   pc.ID = lId
   pc.Key = sKey
   If Not IsMissing(Title) Then
      pc.Title = Title
      fTextChanged "", Title
   End If
   ' First put it into m_colBars:
   If (lIndex > 0) Then
      m_colBars.Add pc, "C:" & lId, lIndex
   Else
      m_colBars.Add pc, "C:" & lId
   End If
   ' add the id to the key collection
   If (lIndex > 0) Then
      m_colBarKeys.Add lId, pc.Key, lIndex
   Else
      m_colBarKeys.Add lId, pc.Key
   End If
   
   ' Have the title measured:
   fMeasureTitle lId
   
   ' draw:
   UserControl_Resize
   
   ' Create the object:
   Dim cB As New cExplorerBar
   cB.fInit UserControl.hWnd, lId
   Set fAddBar = cB
   
End Function
Friend Function fGetBarInternal(ByVal lId As Long) As pcExplorerBar
   Set fGetBarInternal = m_colBars.Item("C:" & lId)
End Function
Friend Function fGetItemInternal(ByVal lId As Long) As pcExplorerBarItem
   Set fGetItemInternal = m_colItems.Item("C:" & lId)
End Function
Friend Sub fExpandBar(pc As pcExplorerBar, ByVal iDir As Long)
Dim lStart As Long
Dim lTarget As Long
Dim bScrollNow As Boolean
Dim i As Long
Dim lAlpha As Long
Dim lPos As Long
Dim iMinDir As Long

   bScrollNow = m_cScrollBar.Visible(efsVertical)

   If (iDir > 0) Then
      pc.Expanding = True
      lStart = 0
      If (bScrollNow) Then
         lTarget = pc.HeightWithScroll
      Else
         lTarget = pc.HeightWithoutScroll
         ' TODO
         ' Need to check here whether that height will
         ' cause the scroll bar to appear.  If so,
         ' lTarget will be pc.HeightWithScroll
      End If
   Else
      pc.Collapsing = True
      lTarget = 0
      If (bScrollNow) Then
         lStart = pc.HeightWithScroll
      Else
         lStart = pc.HeightWithoutScroll
      End If
   End If
     
   ' Check if we animate or not:
   If Not (pc.ContainsControl()) Then
     
      If (pc.ItemCount > 25) Then
         iMinDir = iDir * 4
      ElseIf (pc.ItemCount > 50) Then
         iMinDir = iDir * 6
      ElseIf (pc.ItemCount > 75) Then
         iMinDir = iDir * 8
      End If
     
      lPos = lStart
      If (iDir > 0) Then
         pc.CollapseOffset = (lTarget - lPos)
      Else
         pc.CollapseOffset = 0
      End If
      
      Do While Not (lPos = lTarget)
         lPos = lPos + iDir
         If (iDir > 0) Then
            pc.CollapseOffset = pc.CollapseOffset - iDir
         Else
            pc.CollapseOffset = pc.CollapseOffset + iDir
         End If
         If (iDir > 0) Then
            If (lPos > lTarget) Then
               lPos = lTarget
               pc.CollapseOffset = 0
            End If
         Else
            If (lPos < lTarget) Then
               lPos = lTarget
               pc.CollapseOffset = 0
            End If
         End If
         pc.Height = lPos
               
         lAlpha = 255 * lPos / Abs(lStart - lTarget)
         pc.Alpha = lAlpha
         
         pMeasure
         pPaint
         pResizeContainedControls
         UserControl.Refresh
         
         If (Abs(iDir) < 32) Then
            iDir = iDir + Sgn(iDir)
         Else
            iDir = iDir + iMinDir
         End If
         
      Loop
   
   Else
      pc.Height = lTarget
      pc.Alpha = 255
   
   End If
   
   If (iDir > 0) Then
      pc.State = eBarExpanded
   Else
      pc.State = eBarCollapsed
   End If
   pc.Expanding = False
   pc.Collapsing = False
   pc.Alpha = 255
   
   fEnsureBarVisible pc.ID
   
   pMeasure
   pPaint
   pResizeContainedControls
   UserControl.Refresh
   
End Sub
Friend Sub fEnsureItemVisible(ByVal lBarId As Long, ByVal lItemId As Long)
Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim lTop As Long
Dim iDir As Long
Dim lNow As Long
Dim lTarget As Long
Dim i As Long
Dim bComplete As Boolean
Dim tR As RECT

   ' First check if the bar which contains this item is expanded:
   Set pc = m_colBars.Item("C:" & lBarId)
   If (pc.CanExpand) Then
      If (pc.State = eBarCollapsed) Then
         fExpandBar pc, 1
      End If
   End If

   If (m_cScrollBar.Visible(efsVertical)) Then
   
      GetClientRect UserControl.hWnd, tR
      
      ' Now find out where the item is in the display and check
      ' if it can be seen:
      lTop = pc.Top - m_cScrollBar.Value(efsVertical)
      lTop = lTop + pc.TitleHeightWithScroll
      For i = 1 To pc.ItemCount
         Set itm = pc.Item(i)
         If (itm.ID = lItemId) Then
            Exit For
         End If
         lTop = lTop + itm.HeightWithScroll + itm.SpacingAfter
      Next i
            
      ' Is the thing actually off screen?
      If (lTop < tR.Top) Or (lTop + itm.HeightWithScroll > tR.bottom) Then
         
         lNow = m_cScrollBar.Value(efsVertical)
         lTarget = lNow + lTop
         
         Debug.Print "Item Is Off Screen", lTarget, lNow
         
         iDir = IIf(lTarget < lNow, -1, 1)
         Do While Not bComplete
            lNow = lNow + iDir
            If (iDir > 0) Then
               If (lNow > lTarget) Then
                  lNow = lTarget
                  bComplete = True
               End If
            Else
               If (lNow < lTarget) Then
                  lNow = lTarget
                  bComplete = True
               End If
            End If
            m_cScrollBar.Value(efsVertical) = lNow
            iDir = iDir + Sgn(iDir)
         Loop
         
         
      End If
   
   End If
   
End Sub

Friend Sub fEnsureBarVisible(ByVal lId As Long)
Dim pc As pcExplorerBar
Dim lTop As Long
Dim lHeight As Long
Dim tR As RECT
Dim lNow As Long
Dim lTarget As Long
Dim iDir As Long
Dim bComplete As Boolean

   If (m_cScrollBar.Visible(efsVertical)) Then
      
      GetClientRect UserControl.hWnd, tR
      Set pc = m_colBars.Item("C:" & lId)
      lTop = pc.Top - m_cScrollBar.Value(efsVertical)
      lHeight = pc.HeightWithScroll + pc.TitleHeightWithScroll + m_lBarSpacing
       / 2
      
      ' Is the thing actually off screen?
      If (lTop < tR.Top) Or (lTop + lHeight > tR.bottom) Then
      
         lNow = m_cScrollBar.Value(efsVertical)
         If (lHeight > tR.bottom - tR.Top) Then
            ' Best we can do is to ensure the top is
            ' visible:
            lTarget = lNow + lTop
         Else
            ' We can show the entire item:
            lTarget = (pc.Top + lHeight) - (tR.bottom - tR.Top)
         End If
                 
         
         iDir = IIf(lTarget < lNow, -1, 1)
         Do While Not bComplete
            lNow = lNow + iDir
            If (iDir > 0) Then
               If (lNow > lTarget) Then
                  lNow = lTarget
                  bComplete = True
               End If
            Else
               If (lNow < lTarget) Then
                  lNow = lTarget
                  bComplete = True
               End If
            End If
            m_cScrollBar.Value(efsVertical) = lNow
            iDir = iDir + Sgn(iDir)
         Loop
         
         
      End If
   End If
   
End Sub
Friend Function fAddItem( _
      ByVal lBarId As Long, _
      Optional Index As Variant, _
      Optional Key As Variant, _
      Optional Text As Variant, _
      Optional IconIndex As Variant, _
      Optional ItemType As Variant _
   ) As cExplorerBarItem
   
   ' Get bar to add to:
   Dim pc As pcExplorerBar
   Set pc = m_colBars.Item("C:" & lBarId)
   
   ' Verify the Index is ok:
   Dim lIndex As Long
   If Not IsMissing(Index) Then
      If (IsNumeric(Index)) Then
         On Error Resume Next
         lIndex = CLng(Index)
         If (Err.Number = 0) And (Index > 0) And (Index <= pc.ItemCount) Then
            On Error GoTo 0
            ' ok
         Else
            On Error GoTo 0
            gErr 9, "vbalExplorerBarCtl"
            Exit Function
         End If
      Else
         On Error Resume Next
         lIndex = pc.ItemIndex(Index)
         If (Err.Number = 0) Then
            ' ok
            On Error GoTo 0
         Else
            ' Index is no good
            On Error GoTo 0
            gErr 9, "vbalExplorerBarCtl"
            Exit Function
         End If
      End If
   End If
   
   ' Check if the specified key is ok:
   On Error GoTo 0
   Dim sKey As String
   If Not IsMissing(Key) Then
      If IsNumeric(Key) Then
         gErr 13, "vbalExplorerBarCtl"
         Exit Function
      Else
         On Error Resume Next
         Dim lIdExisting As Long
         Dim pcBar As pcExplorerBar
         For Each pcBar In m_colBars
            lIdExisting = pcBar.IDForKey(Key)
            If (Err.Number = 0) Then
               ' its no good
               On Error GoTo 0
               gErr 457, "vbalExplorerBarCtl"
               Exit Function
            Else
               sKey = Key
            End If
         Next
         On Error GoTo 0
      End If
   End If
   
   ' Ok we're ready:
   Dim lId As Long
   lId = NextId
   If (sKey = "") Then
      sKey = "C:" & lId
   End If
   
   ' Add or insert the item:
   Dim itm As New pcExplorerBarItem
   itm.ID = lId
   itm.Key = sKey
   If Not IsMissing(Text) Then
      itm.Text = Text
      fTextChanged "", Text
   End If
   If Not IsMissing(IconIndex) Then
      itm.IconIndex = IconIndex
   End If
   If Not IsMissing(ItemType) Then
      itm.ItemType = ItemType
   End If
   itm.BarID = lBarId
   
   ' First add it to the m_colItems collection:
   m_colItems.Add itm, "C:" & lId
   
   ' Now add it to the bar's collection:
   pc.AddItem itm, lIndex, Index
   
   ' Have the item measured:
   fMeasureItem lBarId, itm.ID
   
   ' draw:
   UserControl_Resize
   
   ' Return the object:
   Dim cI As New cExplorerBarItem
   cI.fInit UserControl.hWnd, lBarId, lId
   Set fAddItem = cI
      
      
End Function

Friend Sub fMeasureTitle(ByVal lBarId As Long)
Dim pc As pcExplorerBar
Dim lHDC As Long
Dim hFont As Long
Dim hFontOld As Long
Dim hTheme As Long
Dim sMeasureText As String
Dim lMeasureStyle As Long
Dim lHeightWith As Long
Dim lHeightWithout As Long
Dim lHeightOrigWith As Long
Dim lHeightOrigWithout As Long
Dim tR As RECT
Dim tTextR As RECT
Dim tBmp As BITMAP
Dim lSingleLineHeight As Long
   
   Set pc = m_colBars("C:" & lBarId)
   lHeightOrigWith = pc.TitleHeightWithScroll
   lHeightOrigWithout = pc.TitleHeightWithoutScroll
   
   hTheme = plGetTheme()
   GetWindowRect UserControl.hWnd, tR
   
   lHDC = m_cDibFade.hdc
   OffsetRect tR, -tR.left, -tR.Top
         
   pc.SingleLineTitleWithScroll = True
   pc.SingleLineTitleWithoutScroll = True
         
   If (m_bUseExplorerTheme) And Not (hTheme = 0) And (m_eStyle = eDefaultStyle)
    Then
      
      GetObjectAPI m_hDib(8), Len(tBmp), tBmp
      lHeightWith = tBmp.bmHeight
      lHeightWithout = lHeightWith
      
   Else
   
      hFont = m_cNCM.BoldenedFontHandle(IconFont)
      hFontOld = SelectObject(m_cDibFade.hdc, hFont)
      
      tR.left = tR.left + m_lMargin + 4
      tR.right = tR.right - m_lMargin - 4
      
      If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
       (m_ptrVB6ImageListBarTitle = 0)) Then
         tR.left = tR.left + m_lBarTitleIconSize + 4
      End If
      
      If (pc.CanExpand) Then
         If (m_hDib(0) = 0) Then
            tR.right = tR.right - 20
         Else
            GetObjectAPI m_hDib(0), Len(tBmp), tBmp
            tR.right = tR.right - tBmp.bmWidth - 4
         End If
         tR.right = tR.right - 4
      End If
      
      If (m_eStyle = eSearchStyle) Then
         
         tR.right = tR.right - 8
         ' We can have multi-line title captions
         LSet tTextR = tR
         DrawText m_cDibFade.hdc, "Xg", -1, tTextR, DT_SINGLELINE Or DT_CALCRECT
         lSingleLineHeight = tTextR.bottom - tTextR.Top
         
         sMeasureText = pc.Title
         If Len(sMeasureText) < 3 Then
            sMeasureText = "Xg"
         End If
         lMeasureStyle = DT_CALCRECT Or DT_WORDBREAK
         
         LSet tTextR = tR
         DrawText m_cDibFade.hdc, sMeasureText, -1, tTextR, lMeasureStyle
         lHeightWithout = tTextR.bottom - tTextR.Top
         pc.SingleLineTitleWithoutScroll = (lHeightWithout <= lSingleLineHeight
          + 2)
         lHeightWithout = lHeightWithout + 11
         
         LSet tTextR = tR
         tTextR.right = tTextR.right - m_cNCM.ScrollWidth
         DrawText m_cDibFade.hdc, sMeasureText, -1, tTextR, lMeasureStyle
         lHeightWith = tTextR.bottom - tTextR.Top
         pc.SingleLineTitleWithScroll = (lHeightWith <= lSingleLineHeight + 2)
         lHeightWith = lHeightWith + 11

      Else
         
         ' Only one line
         sMeasureText = "Xg"
         lMeasureStyle = DT_SINGLELINE Or DT_CALCRECT
         
         LSet tTextR = tR
         DrawText m_cDibFade.hdc, sMeasureText, -1, tTextR, lMeasureStyle
         lHeightWithout = tTextR.bottom - tTextR.Top + 11
         lHeightWith = lHeightWithout
                  
      End If
      
   End If
   
   lHeightWith = IIf(lHeightWith < 24, 24, lHeightWith)
   lHeightWithout = IIf(lHeightWithout < 24, 24, lHeightWithout)
   
   pc.TitleTextHeightWithScroll = lHeightWith
   pc.TitleTextHeightWithoutScroll = lHeightWithout
   
   If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
    (m_ptrVB6ImageListBarTitle = 0)) Then
      lHeightWith = IIf(lHeightWith < m_lBarTitleIconSize, m_lBarTitleIconSize,
       lHeightWith)
      lHeightWithout = IIf(lHeightWithout < m_lBarTitleIconSize,
       m_lBarTitleIconSize, lHeightWithout)
   End If
   pc.TitleHeightWithScroll = lHeightWith
   pc.TitleHeightWithoutScroll = lHeightWithout
   
   SelectObject m_cDibFade.hdc, hFontOld ' Corrected GDI leak 2003-07-05
   DeleteObject hFont

   If Not (hTheme = 0) Then
      CloseThemeData hTheme
   End If
   
   If Not (lHeightOrigWith = pc.TitleHeightWithScroll) Or _
      Not (lHeightOrigWithout = pc.TitleHeightWithoutScroll) Then
      pMeasure
      pPaint
      UserControl.Refresh
   End If
   
End Sub

Friend Sub fMeasureItem(ByVal lBarId As Long, ByVal lItemId As Long)

Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim lHDC As Long
Dim tR As RECT
Dim tTextR As RECT
Dim lWidthNoScroll As Long
Dim lWidthScroll As Long
Dim hFontOld As Long
Dim hTheme As Long
Dim lHeight As Long
Dim lHeightOrigWith As Long
Dim lHeightOrigWithout As Long
Dim iFnt As IFont

   Set pc = m_colBars("C:" & lBarId)
   lHeightOrigWith = pc.HeightWithScroll
   lHeightOrigWithout = pc.HeightWithoutScroll
   
   Set itm = m_colItems("C:" & lItemId)
   
   If (itm.ItemType = eItemControlPlaceHolder) Then
      itm.HeightWithoutScroll = itm.ControlHeight
      itm.HeightWithScroll = itm.ControlHeight
      pResizeContainedControl pc, itm
   Else
      hTheme = plGetTheme()
      GetWindowRect UserControl.hWnd, tR
      
      lHDC = m_cDibFade.hdc
      OffsetRect tR, -tR.left, -tR.Top
      
      lWidthNoScroll = tR.right - tR.left - m_lMargin * 2
      If (itm.IconIndex > -1) Then
         lWidthNoScroll = lWidthNoScroll - m_lIconSize - m_lMargin \ 2
      End If
      lWidthScroll = lWidthNoScroll - m_cNCM.ScrollWidth
   
      ' Choose the appropriate font:
      If (itm.Font Is Nothing) Then
         Set iFnt = m_cNCM.Font(lHDC, IconFont)
      Else
         Set iFnt = itm.Font
      End If
      If (itm.Bold) Then
         iFnt.Bold = True
      End If
      hFontOld = SelectObject(lHDC, iFnt.hFont)
      
      LSet tTextR = tR
      tTextR.right = lWidthNoScroll - 23
      DrawText lHDC, itm.Text, -1, tTextR, DT_LEFT Or DT_WORDBREAK Or
       DT_CALCRECT 'Or DT_NOPREFIX
      lHeight = tTextR.bottom - tTextR.Top
      If (lHeight < m_lIconSize) Then
         lHeight = m_lIconSize
      End If
      lHeight = lHeight + 2
      itm.HeightWithoutScroll = lHeight
      
      LSet tTextR = tR
      tTextR.right = lWidthScroll - 23
      DrawText lHDC, itm.Text, -1, tTextR, DT_LEFT Or DT_WORDBREAK Or
       DT_CALCRECT 'Or DT_NOPREFIX
      lHeight = tTextR.bottom - tTextR.Top
      If (lHeight < m_lIconSize) Then
         lHeight = m_lIconSize
      End If
      lHeight = lHeight + 2
      itm.HeightWithScroll = lHeight
      
      SelectObject lHDC, hFontOld
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
   
   End If
   
   ' Now calculate the overall height of the item this is
   ' associated with:
   pc.SetHeightFromItems
   
   If Not (lHeightOrigWith = pc.HeightWithScroll) Or _
      Not (lHeightOrigWithout = pc.HeightWithoutScroll) Then
      pMeasure
      pPaint
      UserControl.Refresh
   End If
   

End Sub
   
Friend Sub fRemoveItem(ByVal lId As Long, ByVal Key As Variant)
Dim pc As pcExplorerBar
   If (fVerifyId(lId, 1)) Then
      Set pc = m_colBars.Item("C:" & lId)
      lId = pc.IDForKey(Key)
      If (lId > 0) Then
         Dim iItem As Long
         Dim itm As pcExplorerBarItem
         Dim ctl As Control
         ' we can remove it:
         iItem = pc.ItemIndex(Key)
         Set itm = pc.Item(iItem)
         If Not (itm.lPtrPanel = 0) Then
            Set ctl = ObjectFromPtr(itm.lPtrPanel)
            ctl.Visible = False
         End If
         
         m_colItems.Remove "C:" & lId
         pc.RemoveItem lId
         
         ' Resize the bar:
         fBarChanged pc.ID, True, False
         
         ' draw:
         UserControl_Resize
         
      End If
   End If
End Sub
Friend Function fVerifyId(ByVal lId As Long, ByVal lIdType As Long) As Boolean
   Select Case lIdType
   Case 0
      fVerifyId = True
   Case 1
      On Error Resume Next
      Dim o As Object
      Set o = m_colBars.Item("C:" & lId)
      fVerifyId = (Err.Number = 0)
   Case 2
      On Error Resume Next
      Set o = m_colItems.Item("C:" & lId)
      fVerifyId = (Err.Number = 0)
   Case Else
      Debug.Assert "Incorrect ID Type" = ""
   End Select
   On Error GoTo 0
End Function

Public Property Get ShowFocusRect() As Boolean
Attribute ShowFocusRect.VB_Description = "Gets/sets whether the focus rectangle
 is drawn once the user makes the first keyboard action in the control.  The
 Bars.Clear method reset s internal tracking of whether the user has made a
 keyboard action or not."
   ShowFocusRect = m_bShowFocusRect
End Property
Public Property Let ShowFocusRect(ByVal bState As Boolean)
   m_bShowFocusRect = bState
   PropertyChanged "ShowFocusRect"
End Property

Public Property Get BackColorStart() As OLE_COLOR
Attribute BackColorStart.VB_Description = "Gets/sets the start colour of the
 gradient background of the control.  Set to -1 for the default colour."
   BackColorStart = m_oBackColorStart
End Property
Public Property Let BackColorStart(ByVal oColor As OLE_COLOR)
   If Not (oColor = m_oBackColorStart) Then
      m_oBackColorStart = oColor
      PropertyChanged "BackColorStart"
   End If
End Property
Public Property Get BackColorEnd() As OLE_COLOR
Attribute BackColorEnd.VB_Description = "Gets/sets the end colour of the
 gradient background of the control.  Set to -1 for the default colour."
   BackColorEnd = m_oBackColorEnd
End Property
Public Property Let BackColorEnd(ByVal oColor As OLE_COLOR)
   If Not (oColor = m_oBackColorEnd) Then
      m_oBackColorEnd = oColor
      PropertyChanged "BackColorEnd"
   End If
End Property
Public Property Get UseExplorerTransitionStyle() As Boolean
Attribute UseExplorerTransitionStyle.VB_Description = "For future expansion.
 Not supported in this release."
   UseExplorerTransitionStyle = m_bUseExplorerTransitionStyle
End Property
Public Property Let UseExplorerTransitionStyle(ByVal bState As Boolean)
   If Not (m_bUseExplorerTransitionStyle = bState) Then
      m_bUseExplorerTransitionStyle = bState
      PropertyChanged "UseExplorerTransitionStyle"
   End If
End Property
Public Property Get UseExplorerStyle() As Boolean
Attribute UseExplorerStyle.VB_Description = "Gets/sets the drawing mode of the
 control.  The default is True, when the control uses the XP Theme if one is
 set otherwise draws using a Windows Classic style.  When false, the control
 draws using an emulation of the themed XP version."
   UseExplorerStyle = m_bUseExplorerTheme
End Property
Public Property Let UseExplorerStyle(ByVal bState As Boolean)
   
   If Not (m_bUseExplorerTheme = bState) Then
      
      m_bUseExplorerTheme = bState
      If (IsXp And m_bUseExplorerTheme) Or (Not (m_bUseExplorerTheme)) Then
         If Not (pbLoadShellStyleBitmaps()) Then
            ' If we can't load the shell style DLL then we're stuffed
            m_bUseExplorerTheme = False
            pbLoadShellStyleBitmaps
         End If
      End If
      
      If Not m_colBars Is Nothing Then
         Dim pc As pcExplorerBar
         For Each pc In m_colBars
            fBarChanged pc.ID, False, True
         Next
         pbColouriseWatermarks
         pMeasure
      End If
      
      pPaint
      UserControl.Refresh
      
      PropertyChanged "UseExplorerTheme"
   End If
End Property
Public Property Get Style() As EExplorerBarStyles
Attribute Style.VB_Description = "Gets/sets whether the control draws like the
 Search bar or in the default way."
   Style = m_eStyle
End Property
Public Property Let Style(ByVal eStyle As EExplorerBarStyles)
Dim pc As pcExplorerBar

   If (Not (m_eStyle = eStyle)) Then
      m_eStyle = eStyle
   
      pbCreateBitmapWorkDC
      pbLoadShellStyleBitmaps
   
      If Not (m_colBars Is Nothing) Then
         For Each pc In m_colBars
            fBarChanged pc.ID, False, True
         Next
         pbColouriseWatermarks
         pMeasure
      End If
      
      pPaint
      UserControl.Refresh
      
      PropertyChanged "Style"
   End If
End Property
Public Property Get DefaultPanelColor(ByVal bIsSpecial As Boolean) As OLE_COLOR
Attribute DefaultPanelColor.VB_Description = "Gets the background colour of the
 panel holding the items in a bar."
Dim hTheme As Long
   hTheme = plGetTheme()
   If (bIsSpecial) Then
      DefaultPanelColor = m_lThemePanelColor
   Else
      DefaultPanelColor = BlendColor(m_lThemePanelColor,
       TranslateColor(vbActiveTitleBar), 230)
   End If
   If (m_bUseExplorerTheme) Then
      If (hTheme = 0) Then
         DefaultPanelColor = vbWindowBackground
      End If
   End If
   If Not (hTheme = 0) Then
      CloseThemeData hTheme
   End If
End Property
Public Property Let ImageList( _
        ByRef vImageList As Variant _
    )
Attribute ImageList.VB_Description = "Associates an ImageList with the control.
  If using a Microsoft ImageList, pass the object as the value, otherwise pass
 the ComCtl32 hImageList handle."
    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", "cVGrid.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
Public Property Let BarTitleImageList( _
        ByRef vImageList As Variant _
    )
    m_hImlBarTitle = 0
    m_ptrVB6ImageListBarTitle = 0
    If (VarType(vImageList) = vbLong) Then
        ' Assume a handle to an image list:
        m_hImlBarTitle = 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_hImlBarTitle = 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_ptrVB6ImageListBarTitle = ObjPtr(o)
            End If
        Else
            Debug.Print "Failed to Get Image list Handle", "cVGrid.ImageList"
        End If
        On Error GoTo 0
    End If
    If (m_hImlBarTitle <> 0) Then
        If (m_ptrVB6ImageListBarTitle <> 0) Then
            m_lBarTitleIconSize = vImageList.ImageHeight
        Else
            Dim rc As RECT
            ImageList_GetImageRect m_hImlBarTitle, 0, rc
            m_lBarTitleIconSize = rc.bottom - rc.Top
        End If
    End If
End Property
Public Property Get Redraw() As Boolean
Attribute Redraw.VB_Description = "Gets/sets whether changes to the appearance
 or items/bars in the control are redrawn.  Turn off to make many changes
 quickly."
   Redraw = m_bRedraw
End Property
Public Property Let Redraw(ByVal bState As Boolean)
   If Not (m_bRedraw = bState) Then
      m_bRedraw = bState
      If (m_bRedraw) Then
         ' TODO: Here we want to scroll the items from their
         ' current positions to the new desired positions
         UserControl_Resize
      End If
      PropertyChanged "Redraw"
   End If
End Property

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

Public Property Get Bars() As cExplorerBars
Attribute Bars.VB_Description = "Gets the collection of bars associated with
 the control."
   Dim cB As New cExplorerBars
   cB.fInit UserControl.hWnd
   Set Bars = cB
End Property

Private Sub pPaintBackground( _
      ByVal lHDC As Long, _
      ByVal hTheme As Long, _
      tR As RECT _
   )
   If (hTheme = 0) Then
      If (m_bUseExplorerTheme) Then
         Dim hBr As Long
         hBr = GetSysColorBrush(vbWindowBackground And &H1F&)
         FillRect lHDC, tR, hBr
         DeleteObject hBr
      Else
         ' Emulate XP Style:
         Dim lBackColorStart As Long
         Dim lBackColorEnd As Long
         If (BackColorStart = CLR_INVALID) Then
            lBackColorStart = BlendColor(vbInactiveTitleBar, &HFFFFFF, 128)
         Else
            lBackColorStart = BackColorStart
         End If
         If (BackColorEnd = CLR_INVALID) Then
            lBackColorEnd = BlendColor(vbActiveTitleBar, &HFFFFFF, 192)
         Else
            lBackColorEnd = BackColorEnd
         End If
         GradientFillRect lHDC, tR, lBackColorStart, lBackColorEnd,
          GRADIENT_FILL_RECT_V
      End If
   Else
      ' Draw the background:
      DrawThemeBackground hTheme, lHDC, 0, 0, tR, tR
   End If
End Sub
Private Sub pPaintBars( _
      ByVal lHDC As Long, _
      ByVal hTheme As Long, _
      tR As RECT _
   )
Dim pc As pcExplorerBar

   If Not m_colBars Is Nothing Then
      
      For Each pc In m_colBars
         pPaintBar pc, lHDC, hTheme, tR
      Next
         
      pPaintBorders lHDC, hTheme, tR
      
   End If
End Sub

Private Sub pPaintBorders( _
      ByVal lHDC As Long, _
      ByVal hTheme As Long, _
      tR As RECT _
   )
Dim pc As pcExplorerBar
Dim tWorkR As RECT
Dim hPen As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI

   If (m_eStyle = eSearchStyle) Then
      If (m_colBars.Count > 0) Then
         
      
         Set pc = m_colBars(m_colBars.Count)
         LSet tWorkR = tR
         tWorkR.Top = tR.Top + m_lBarSpacing
         tWorkR.left = tR.left + m_lMargin
         tWorkR.right = tR.right - m_lMargin
         If (m_cScrollBar.Visible(efsVertical)) Then
            tWorkR.bottom = tR.Top + pc.Top + pc.HeightWithScroll +
             pc.TitleHeightWithScroll
            OffsetRect tWorkR, 0, -m_cScrollBar.Value(efsVertical)
         Else
            tWorkR.bottom = tR.Top + pc.Top + pc.HeightWithoutScroll +
             pc.TitleHeightWithoutScroll
         End If
         
         hPen = CreatePen(PS_SOLID, 1, &HFFFFFF)
         hPenOld = SelectObject(lHDC, hPen)
         
         ' Top
         MoveToEx lHDC, tWorkR.left + 1, tWorkR.Top - 1, tJunk
         LineTo lHDC, tWorkR.right - 1, tWorkR.Top - 1
         ' Top-left
         MoveToEx lHDC, tWorkR.left + 1, tWorkR.Top, tJunk
         LineTo lHDC, tWorkR.left - 1, tWorkR.Top
         MoveToEx lHDC, tWorkR.left, tWorkR.Top + 1, tJunk
         LineTo lHDC, tWorkR.left - 1, tWorkR.Top + 1
         ' Top-right
         MoveToEx lHDC, tWorkR.right - 2, tWorkR.Top, tJunk
         LineTo lHDC, tWorkR.right, tWorkR.Top
         MoveToEx lHDC, tWorkR.right - 1, tWorkR.Top + 1, tJunk
         LineTo lHDC, tWorkR.right - 2, tWorkR.Top + 1
                  
         ' Left
         MoveToEx lHDC, tWorkR.left - 1, tWorkR.Top + 1, tJunk
         LineTo lHDC, tWorkR.left - 1, tWorkR.bottom - 1
         ' Right
         MoveToEx lHDC, tWorkR.right, tWorkR.Top + 1, tJunk
         LineTo lHDC, tWorkR.right, tWorkR.bottom - 1
         
         ' Bottom
         MoveToEx lHDC, tWorkR.left + 1, tWorkR.bottom, tJunk
         LineTo lHDC, tWorkR.right - 1, tWorkR.bottom
         ' Bottom-left
         MoveToEx lHDC, tWorkR.left + 1, tWorkR.bottom - 1, tJunk
         LineTo lHDC, tWorkR.left - 1, tWorkR.bottom - 1
         MoveToEx lHDC, tWorkR.left, tWorkR.bottom - 2, tJunk
         LineTo lHDC, tWorkR.left - 1, tWorkR.bottom - 2
         ' Bottom-right
         MoveToEx lHDC, tWorkR.right - 2, tWorkR.bottom - 1, tJunk
         LineTo lHDC, tWorkR.right, tWorkR.bottom - 1
         MoveToEx lHDC, tWorkR.right - 1, tWorkR.bottom - 2, tJunk
         LineTo lHDC, tWorkR.right, tWorkR.bottom - 2
         
         SelectObject lHDC, hPenOld
         DeleteObject hPen
      
      End If
      
   End If
   
End Sub

Private Sub pPaintItem( _
      itm As pcExplorerBarItem, _
      ByVal lHDC As Long, _
      ByVal hTheme As Long, _
      tR As RECT _
   )
   
Dim tItemR As RECT
Dim hFontOld As Long
Dim pc As pcExplorerBar
   
   Set pc = m_colBars("C:" & itm.BarID)
   
   LSet tItemR = tR
   tItemR.Top = tItemR.Top + itm.Top
   tItemR.left = tItemR.left + m_lMargin
   tItemR.right = tItemR.right - m_lMargin
   
   If (pc.Collapsing) Then
      OffsetRect tItemR, 0, pc.CollapseOffset
   End If

   ' Draw the icon:
   Dim tTextR As RECT
   LSet tTextR = tItemR
   
   If (itm.IconIndex > -1) Then
      Dim tIconR As RECT
      LSet tIconR = tItemR
      ImageListDrawIcon m_ptrVB6ImageList, lHDC, m_hIml, itm.IconIndex,
       tIconR.left, tIconR.Top
      tTextR.left = tTextR.left + m_lMargin \ 2 + m_lIconSize
   End If
   
   SetBkMode lHDC, TRANSPARENT
   If (itm.MouseDown Or itm.MouseOver) Then
      If Not (hTheme = 0) Or (m_bUseExplorerTheme) Or (itm.TextColorOver =
       CLR_INVALID) Then
         If (itm.ItemType = eItemText) Then
            SetTextColor lHDC, TranslateColor(vbWindowText)
         Else
            SetTextColor lHDC, BlendColor(vbHighlight, 0, 240)
         End If
      Else
         SetTextColor lHDC, TranslateColor(itm.TextColorOver)
      End If
   Else
      If Not (hTheme = 0) Or (m_bUseExplorerTheme) Or (itm.TextColor =
       CLR_INVALID) Then
         If (itm.ItemType = eItemText) Then
            SetTextColor lHDC, TranslateColor(vbWindowText)
         Else
            SetTextColor lHDC, BlendColor(vbHighlight, 0, 192)
         End If
      Else
         SetTextColor lHDC, TranslateColor(itm.TextColor)
      End If
   End If
   Dim iFnt As IFont
   If (itm.Font Is Nothing) Then
      Set iFnt = m_cNCM.Font(lHDC, IconFont)
   Else
      itm.Font.Clone iFnt
   End If
   If (itm.MouseDown Or itm.MouseOver) Then
      iFnt.Underline = True
   End If
   If (itm.Bold) Then
      iFnt.Bold = True
   End If
   hFontOld = SelectObject(lHDC, iFnt.hFont)
   DrawText lHDC, itm.Text, -1, tTextR, DT_LEFT Or DT_WORDBREAK 'Or DT_NOPREFIX
   SelectObject lHDC, hFontOld
   
   If (m_bShowFocusRect And m_bFocus And (itm.ID = m_lIdSelItem) And
    m_bHaveUsedKeys) Then
      tItemR.left = tItemR.left - 3
      tItemR.right = tTextR.right
      tItemR.Top = tItemR.Top - 3
      If (m_cScrollBar.Visible(efsVertical)) Then
         tItemR.bottom = tItemR.Top + itm.HeightWithScroll + 4
      Else
         tItemR.bottom = tItemR.Top + itm.HeightWithoutScroll + 4
      End If
      DrawFocusRect lHDC, tItemR
   End If
   
End Sub

Private Sub pGetBarRect( _
      pc As pcExplorerBar, _
      tR As RECT, _
      tBarR As RECT _
   )
   LSet tBarR = tR
   tBarR.Top = pc.Top
   If (m_cScrollBar.Visible(efsVertical)) Then
      OffsetRect tBarR, 0, -m_cScrollBar.Value(efsVertical)
      tBarR.bottom = tBarR.Top + pc.HeightWithScroll
      tBarR.bottom = tBarR.bottom + pc.TitleHeightWithScroll
   Else
      tBarR.bottom = tBarR.Top + pc.HeightWithoutScroll
      tBarR.bottom = tBarR.bottom + pc.TitleHeightWithoutScroll
   End If
   tBarR.left = tBarR.left + m_lMargin
   tBarR.right = tBarR.right - m_lMargin
   
End Sub

Private Sub pPaintBar( _
      pc As pcExplorerBar, _
      ByVal lHDC As Long, _
      ByVal hTheme As Long, _
      tR As RECT, _
      Optional ByVal bHighlight As Boolean _
   )
Dim tBarR As RECT
Dim tDCR As RECT
Dim tTitleR As RECT
Dim tWorkR As RECT
Dim tSearchWorkR As RECT
Dim iPartId As Long
Dim tBmp As BITMAP
Dim hBr As Long
Dim hPen As Long
Dim hPenBorder As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI
Dim hFont As Long
Dim hFontOld As Long
Dim iItem As Long
Dim iWidth As Long
Dim iHeight As Long
Dim lDrawStyle As Long
Dim itm As pcExplorerBarItem
Dim lIconY As Long
Dim lTextX As Long
   
   If Not m_bRedraw Then
      Exit Sub
   End If
   
   pGetBarRect pc, tR, tBarR
   
   If (tBarR.bottom < tR.Top) Or (tBarR.Top > tR.bottom) Then
      ' nothing to do
      Exit Sub
   End If
   
   ' Else we can draw the bar:
   
   LSet tTitleR = tBarR
   If (pc.CanExpand) Or Len(pc.Title) > 0 Then
      If (m_cScrollBar.Visible(efsVertical)) Then
         tTitleR.bottom = tBarR.Top + pc.TitleHeightWithScroll
      Else
         tTitleR.bottom = tBarR.Top + pc.TitleHeightWithoutScroll
      End If
   Else
      tTitleR.bottom = tBarR.Top
   End If
   
   If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
    (m_ptrVB6ImageListBarTitle = 0)) Then
      lIconY = tTitleR.Top
      lTextX = m_lBarTitleIconSize - 8
      If (m_eStyle = eDefaultStyle) Then
         ' The title bar height needs to be adjusted
         If (m_cScrollBar.Visible(efsVertical)) Then
            tTitleR.Top = tTitleR.bottom - pc.TitleTextHeightWithScroll
         Else
            tTitleR.Top = tTitleR.bottom - pc.TitleTextHeightWithoutScroll
         End If
      End If
   End If
      
   If (m_bUseExplorerTheme) And (hTheme = 0) Then
         
      ' Draw as per XP with Windows Classic Mode applied:
      
      ' Draw title bar:
      If (pc.IsSpecial) Then
         hBr = GetSysColorBrush(vbActiveTitleBar And &H1F&)
         hPenBorder = CreatePen(PS_SOLID, 1, TranslateColor(vbActiveTitleBar))
         SetTextColor lHDC, TranslateColor(vbTitleBarText)
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbTitleBarText))
      Else
         hBr = GetSysColorBrush(vbButtonFace And &H1F&)
         hPenBorder = CreatePen(PS_SOLID, 1, TranslateColor(vbButtonFace))
         SetTextColor lHDC, TranslateColor(vbWindowText)
         hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbWindowText))
      End If
      FillRect lHDC, tTitleR, hBr
      DeleteObject hBr
      
      ' Text:
      LSet tWorkR = tTitleR
      tWorkR.left = tWorkR.left + m_lMargin + 2
      tWorkR.right = tWorkR.right - m_lMargin - 2
      If (pc.CanExpand) Then
         GetObjectAPI m_hDib(0), Len(tBmp), tBmp
         tWorkR.right = tWorkR.right - tBmp.bmWidth - 4
      End If
      If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
       (m_ptrVB6ImageListBarTitle = 0)) Then
         tWorkR.left = tWorkR.left + lTextX
      End If
      
      hFont = m_cNCM.BoldenedFontHandle(IconFont)
      hFontOld = SelectObject(lHDC, hFont)
      
      lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER Or DT_END_ELLIPSIS
      If (m_eStyle = eSearchStyle) Then
         If m_cScrollBar.Visible(efsVertical) Then
            If (pc.SingleLineTitleWithScroll) Then
               lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            Else
               lDrawStyle = DT_LEFT Or DT_WORDBREAK
               tWorkR.Top = tWorkR.Top + 4
            End If
         Else
            If (pc.SingleLineTitleWithoutScroll) Then
               lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            Else
               lDrawStyle = DT_LEFT Or DT_WORDBREAK
               tWorkR.Top = tWorkR.Top + 4
            End If
         End If
      End If
      DrawText lHDC, pc.Title, -1, tWorkR, lDrawStyle
      
      SelectObject lHDC, hFontOld
      If Not (hFont = 0) Then
         DeleteObject hFont
      End If
      
      ' Draw the collapse/expand bitmap:
      LSet tWorkR = tTitleR
      
      If (pc.CanExpand) Then
      
         tWorkR.left = tWorkR.right - 22
         
         tWorkR.Top = tWorkR.Top + (tWorkR.bottom - tWorkR.Top - 16) \ 2
         tWorkR.right = tWorkR.left + 17
         tWorkR.bottom = tWorkR.Top + 16
         hPenOld = SelectObject(lHDC, hPen)

         If (pc.State = eBarExpanded) Then
            MoveToEx lHDC, tWorkR.left + 5, tWorkR.Top + 7, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 4
            LineTo lHDC, tWorkR.left + 12, tWorkR.Top + 8
            MoveToEx lHDC, tWorkR.left + 6, tWorkR.Top + 7, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 5
            LineTo lHDC, tWorkR.left + 11, tWorkR.Top + 8
            
            MoveToEx lHDC, tWorkR.left + 5, tWorkR.Top + 11, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 8
            LineTo lHDC, tWorkR.left + 12, tWorkR.Top + 12
            MoveToEx lHDC, tWorkR.left + 6, tWorkR.Top + 11, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 9
            LineTo lHDC, tWorkR.left + 11, tWorkR.Top + 12
            
         Else
            MoveToEx lHDC, tWorkR.left + 5, tWorkR.Top + 4, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 7
            LineTo lHDC, tWorkR.left + 12, tWorkR.Top + 3
            MoveToEx lHDC, tWorkR.left + 6, tWorkR.Top + 4, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 6
            LineTo lHDC, tWorkR.left + 11, tWorkR.Top + 3
            
            MoveToEx lHDC, tWorkR.left + 5, tWorkR.Top + 8, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 11
            LineTo lHDC, tWorkR.left + 12, tWorkR.Top + 7
            MoveToEx lHDC, tWorkR.left + 6, tWorkR.Top + 8, tJunk
            LineTo lHDC, tWorkR.left + 8, tWorkR.Top + 10
            LineTo lHDC, tWorkR.left + 11, tWorkR.Top + 7
            
         End If
         
         If (pc.MouseDown And pc.MouseOver) Then
            DrawEdgeAPI lHDC, tWorkR, EDGE_RAISED, BF_RECT
         ElseIf (pc.MouseOver) Then
            DrawEdgeAPI lHDC, tWorkR, EDGE_RAISED, BF_RECT
         End If
         
         SelectObject lHDC, hPenOld
         DeleteObject hPen
      End If
      
      ' draw the focus rectangle if required:
      If (m_bShowFocusRect) And (m_bFocus) And (pc.ID = m_lIdSelBar) And
       (m_bHaveUsedKeys) Then
         LSet tWorkR = tTitleR
         tWorkR.right = tWorkR.right - 2
         DrawFocusRect lHDC, tWorkR
      End If
      
      ' draw the icon if required:
      If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
       (m_ptrVB6ImageListBarTitle = 0)) Then
         LSet tWorkR = tTitleR
         If Not (bHighlight) Then
            ImageListDrawIcon m_ptrVB6ImageListBarTitle, lHDC, m_hImlBarTitle,
             pc.IconIndex, tWorkR.left + 4, lIconY
         Else
            m_cDibFade.LoadPictureBlt lHDC, tWorkR.left + 4, tWorkR.Top,
             m_lBarTitleIconSize, tWorkR.bottom - tWorkR.Top
            ImageListDrawIcon m_ptrVB6ImageListBarTitle, m_cDibFade.hdc,
             m_hImlBarTitle, pc.IconIndex, 0, lIconY - tWorkR.Top
            m_cDibFade.PaintPicture lHDC, tWorkR.left + 4, tWorkR.Top,
             m_lBarTitleIconSize, tWorkR.bottom - tWorkR.Top
         End If
      End If
      
      ' if the bar is expanded, then draw it:
      If (pc.State = eBarExpanded) Or (pc.Expanding) Then
         
         ' Fill the background:
         LSet tWorkR = tBarR
         tWorkR.Top = tTitleR.bottom
         OffsetRect tWorkR, -tBarR.left, -tTitleR.bottom
         If (pc.Collapsing) Then
            tWorkR.bottom = tWorkR.bottom + pc.CollapseOffset
         ElseIf (pc.Expanding) Then
            OffsetRect tWorkR, 0, -pc.CollapseOffset
         End If
         
         hBr = GetSysColorBrush(vbWindowBackground And &H1F&)
         FillRect m_cDibFade.hdc, tWorkR, hBr
         DeleteObject hBr
               
         ' Watermark?
         pc.RenderWatermark m_cDibFade.hdc, m_hDC, tWorkR.left, tWorkR.Top,
          tWorkR.right, tWorkR.bottom, m_lMargin, m_lItemSpacing
         
         ' Draw the borders:
         If Not (m_eStyle = eSearchStyle) Then
            hPenOld = SelectObject(m_cDibFade.hdc, hPenBorder)
            MoveToEx m_cDibFade.hdc, tWorkR.right - 1, tWorkR.Top, tJunk
            LineTo m_cDibFade.hdc, tWorkR.right - 1, tWorkR.bottom - 1
            LineTo m_cDibFade.hdc, tWorkR.left, tWorkR.bottom - 1
            LineTo m_cDibFade.hdc, tWorkR.left, tWorkR.Top - 1
            SelectObject m_cDibFade.hdc, hPenOld
         End If
         DeleteObject hPenBorder
         
         ' Draw the subitems:
         LSet tDCR = tBarR
         OffsetRect tDCR, -tDCR.left, -tDCR.Top
         For iItem = 1 To pc.ItemCount
            Set itm = pc.Item(iItem)
            pPaintItem itm, m_cDibFade.hdc, hTheme, tDCR
         Next iItem
                  
         ' Swap mem DC back to display:
         If (pc.Expanding) Then
            OffsetRect tWorkR, 0, pc.CollapseOffset
         End If
         OffsetRect tWorkR, tBarR.left, tTitleR.bottom
         If (pc.Alpha < 255) Then
            ' HERE: ONLY PAINT THE PORTION OF ITEM WHICH SHOULD BE VISIBLE
            ' IE. CHANGE DEST HEIGHT AND SRC TOP
            m_cDibFade.AlphaPaintPicture lHDC, tWorkR.left, tWorkR.Top,
             tWorkR.right - tWorkR.left, tWorkR.bottom - tWorkR.Top, , ,
             pc.Alpha, False
         Else
            m_cDibFade.PaintPicture lHDC, tWorkR.left, tWorkR.Top, tWorkR.right
             - tWorkR.left, tWorkR.bottom - tWorkR.Top
         End If
      End If
      
      DeleteObject hPen
               
   Else
      
      If (pc.IsSpecial) Then
         iPartId = 8 'EBP_SPECIALGROUPHEAD
      Else
         iPartId = 9 'EBP_NORMALGROUPHEAD
      End If
      ' Draw the title:
      
      ' a) Background:
      If (pc.CanExpand) And (m_eStyle = eDefaultStyle) Then
         pDrawShellStyleBitmap lHDC, tTitleR, iPartId, pc
      Else
         If (pc.IsSpecial) Then
            If (pc.PanelBackColor = -1) Then
               hBr = CreateSolidBrush(m_lThemePanelColor)
            Else
               hBr = CreateSolidBrush(TranslateColor(pc.PanelBackColor))
            End If
         Else
            If (pc.PanelBackColor = -1) Then
               hBr = CreateSolidBrush(BlendColor(m_lThemePanelColor,
                TranslateColor(vbActiveTitleBar), 230))
            Else
               hBr = CreateSolidBrush(TranslateColor(pc.PanelBackColor))
            End If
         End If
         FillRect lHDC, tTitleR, hBr
         DeleteObject hBr
      End If
      
      ' b) Text:
      LSet tWorkR = tTitleR
      tWorkR.left = tWorkR.left + m_lMargin
      tWorkR.right = tWorkR.right - m_lMargin
      If (pc.CanExpand) Then
         GetObjectAPI m_hDib(0), Len(tBmp), tBmp
         tWorkR.right = tWorkR.right - tBmp.bmWidth - 4
      End If
      If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
       (m_ptrVB6ImageListBarTitle = 0)) Then
         tWorkR.left = tWorkR.left + lTextX
      End If
      hFont = m_cNCM.BoldenedFontHandle(IconFont)
      hFontOld = SelectObject(lHDC, hFont)
      If (pc.IsSpecial) Then
         If (pc.MouseOver Or pc.MouseDown) Then
            If (pc.TitleForeColorOver = -1) Then
               SetTextColor lHDC, BlendColor(&HFFFFFF, vbHighlight, 128)
            Else
               SetTextColor lHDC, TranslateColor(pc.TitleForeColorOver)
            End If
         Else
            If (pc.TitleForeColor = -1) Then
               SetTextColor lHDC, &HFFFFFF
            Else
               SetTextColor lHDC, TranslateColor(pc.TitleForeColor)
            End If
         End If
      Else
         If (pc.MouseOver Or pc.MouseDown) Then
            If (pc.TitleForeColorOver = -1) Then
               SetTextColor lHDC, BlendColor(vbHighlight, &H0, 240)
            Else
               SetTextColor lHDC, TranslateColor(pc.TitleForeColorOver)
            End If
         Else
            If (pc.TitleForeColor = -1) Then
               SetTextColor lHDC, BlendColor(vbHighlight, &H0, 192)
            Else
               SetTextColor lHDC, TranslateColor(pc.TitleForeColor)
            End If
         End If
      End If
      
      lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER Or DT_END_ELLIPSIS
      If (m_eStyle = eSearchStyle) Then
         If m_cScrollBar.Visible(efsVertical) Then
            If (pc.SingleLineTitleWithScroll) Then
               lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            Else
               lDrawStyle = DT_LEFT Or DT_WORDBREAK
               tWorkR.Top = tWorkR.Top + 4
            End If
         Else
            If (pc.SingleLineTitleWithoutScroll) Then
               lDrawStyle = DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
            Else
               lDrawStyle = DT_LEFT Or DT_WORDBREAK
               tWorkR.Top = tWorkR.Top + 4
            End If
         End If
      End If
      DrawText lHDC, pc.Title, -1, tWorkR, lDrawStyle
      
      SelectObject lHDC, hFontOld
      If Not (hFont = 0) Then
         DeleteObject hFont
      End If
      
      ' Draw the icon:
      If (pc.CanExpand) Then
         If (pc.State = eBarExpanded) Then
            If (pc.IsSpecial) Then
               If (pc.MouseOver Or pc.MouseDown) Then
                  iPartId = 5
               Else
                  iPartId = 4 'EBP_SPECIALGROUPCOLLAPSE
               End If
            Else
               If (pc.MouseOver Or pc.MouseDown) Then
                  iPartId = 1 'EBP_NORMALGROUPCOLLAPSE
               Else
                  iPartId = 0
               End If
            End If
         Else
            If (pc.IsSpecial) Then
               If (pc.MouseOver Or pc.MouseDown) Then
                  iPartId = 7
               Else
                  iPartId = 6 'EBP_SPECIALGROUPEXPAND
               End If
            Else
               If (pc.MouseOver Or pc.MouseDown) Then
                  iPartId = 3
               Else
                  iPartId = 2 ' EBP_NORMALGROUPEXPAND
               End If
            End If
         End If
         LSet tWorkR = tTitleR
         Dim c As New pcAlphaDibSection
         c.CreateFromHBitmap m_hDib(iPartId)
         If Not (hTheme = 0) Then
            c.PreMultiplyAlpha
            c.AlphaPaintPicture lHDC, tWorkR.right - 2 - c.Width, tWorkR.Top + 1
         Else
            c.PaintPicture lHDC, tWorkR.right - 2 - c.Width, tWorkR.Top + 1
         End If
      End If
      
      ' draw the focus rectangle if required:
      If (m_bShowFocusRect) And (m_bFocus) And (pc.ID = m_lIdSelBar) And
       (m_bHaveUsedKeys) Then
         LSet tWorkR = tTitleR
         tWorkR.right = tWorkR.right - 2
         DrawFocusRect lHDC, tWorkR
      End If
      
      ' draw the icon if required:
      If (pc.IconIndex > -1) And ((m_hImlBarTitle = 0) Or
       (m_ptrVB6ImageListBarTitle = 0)) Then
         If Not (bHighlight) Then
            ImageListDrawIcon m_ptrVB6ImageListBarTitle, lHDC, m_hImlBarTitle,
             pc.IconIndex, tWorkR.left + 4, lIconY
         Else
            m_cDibFade.LoadPictureBlt lHDC, tWorkR.left + 4, tWorkR.Top,
             m_lBarTitleIconSize, tWorkR.bottom - tWorkR.Top
            ImageListDrawIcon m_ptrVB6ImageListBarTitle, m_cDibFade.hdc,
             m_hImlBarTitle, pc.IconIndex, 0, lIconY - tWorkR.Top
            m_cDibFade.PaintPicture lHDC, tWorkR.left + 4, tWorkR.Top,
             m_lBarTitleIconSize, tWorkR.bottom - tWorkR.Top
         End If
      End If
      
      ' if the bar is expanded, then draw it:
      If (pc.State = eBarExpanded) Or (pc.Expanding) Then
         
         ' Fill the background:
         LSet tWorkR = tBarR
         tWorkR.Top = tTitleR.bottom
         OffsetRect tWorkR, -tBarR.left, -tTitleR.bottom
         If (pc.Collapsing) Then
            tWorkR.bottom = tWorkR.bottom + pc.CollapseOffset
         End If
         
         If (pc.IsSpecial) Then
            If (pc.PanelBackColor = -1) Then
               hBr = CreateSolidBrush(m_lThemePanelColor)
            Else
               hBr = CreateSolidBrush(TranslateColor(pc.PanelBackColor))
            End If
         Else
            If (pc.PanelBackColor = -1) Then
               hBr = CreateSolidBrush(BlendColor(m_lThemePanelColor,
                TranslateColor(vbActiveTitleBar), 230))
            Else
               hBr = CreateSolidBrush(TranslateColor(pc.PanelBackColor))
            End If
         End If
         FillRect m_cDibFade.hdc, tWorkR, hBr
         DeleteObject hBr
         
         ' Watermark?
         pc.RenderWatermark m_cDibFade.hdc, m_hDC, tWorkR.left, tWorkR.Top,
          tWorkR.right, tWorkR.bottom, m_lMargin, m_lItemSpacing
         
         ' Draw the borders:
         If Not (m_eStyle = eSearchStyle) Then
            hPen = CreatePen(PS_SOLID, 1, &HFFFFFF)
            hPenOld = SelectObject(m_cDibFade.hdc, hPen)
            MoveToEx m_cDibFade.hdc, tWorkR.right - 1, tWorkR.Top, tJunk
            LineTo m_cDibFade.hdc, tWorkR.right - 1, tWorkR.bottom - 1
            LineTo m_cDibFade.hdc, tWorkR.left, tWorkR.bottom - 1
            LineTo m_cDibFade.hdc, tWorkR.left, tWorkR.Top - 1 ' 2003-07-05:
             This was off by 1 pixel
            SelectObject m_cDibFade.hdc, hPenOld
            DeleteObject hPen
         End If
         
         ' Draw the subitems:
         LSet tDCR = tBarR
         OffsetRect tDCR, -tDCR.left, -tDCR.Top
         For iItem = 1 To pc.ItemCount
            Set itm = pc.Item(iItem)
            pPaintItem itm, m_cDibFade.hdc, hTheme, tDCR
         Next iItem
                  
         ' Swap mem DC back to display:
         OffsetRect tWorkR, tBarR.left, tTitleR.bottom
         If (pc.Alpha < 255) Then
            ' HERE: ONLY PAINT THE PORTION OF ITEM WHICH SHOULD BE VISIBLE
            ' IE. CHANGE DEST HEIGHT AND SRC TOP
            If (pc.Expanding) Then
               m_cDibFade.AlphaPaintPicture lHDC, tWorkR.left, tWorkR.Top,
                tWorkR.right - tWorkR.left, tWorkR.bottom - tWorkR.Top -
                pc.CollapseOffset, , pc.CollapseOffset, pc.Alpha, False
            Else
               m_cDibFade.AlphaPaintPicture lHDC, tWorkR.left, tWorkR.Top,
                tWorkR.right - tWorkR.left, tWorkR.bottom - tWorkR.Top, , ,
                pc.Alpha, False
            End If
         Else
            If (pc.Expanding) Then
               m_cDibFade.PaintPicture lHDC, tWorkR.left, tWorkR.Top,
                tWorkR.right - tWorkR.left, tWorkR.bottom - tWorkR.Top -
                pc.CollapseOffset, , pc.CollapseOffset
            Else
               m_cDibFade.PaintPicture lHDC, tWorkR.left, tWorkR.Top,
                tWorkR.right - tWorkR.left, tWorkR.bottom - tWorkR.Top
            End If
         End If
      End If
      
   End If
   
End Sub
Private Sub pPaint()
Dim lHDC As Long
Dim tR As RECT

   If m_bRedraw Then

      lHDC = UserControl.hdc
      GetClientRect UserControl.hWnd, tR
   
      pPaintToDC lHDC, tR
   
   End If
   
End Sub

Private Sub pPaintToDC(ByVal lHDC As Long, tR As RECT)
Dim hTheme As Long
         
   If m_bRedraw Then
         
      ' Load theme if required:
      hTheme = plGetTheme()
         
      ' Paint the background:
      pPaintBackground lHDC, hTheme, tR
      ' Paint also onto the fade out area:
      pPaintBackground m_cDibFade.hdc, hTheme, tR
      
      ' Paint the bars:
      pPaintBars lHDC, hTheme, tR
      
      ' Done
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
   
   End If
   
End Sub

Private Sub pDrawShellStyleBitmap( _
      ByVal lHDC As Long, _
      tR As RECT, _
      ByVal iIndex As Long, _
      pc As pcExplorerBar _
   )
Dim lhBmpOld As Long
Dim bf As BLENDFUNCTION
Dim lBlend As Long
Dim tBmp As BITMAP

   ' 2003-07-05: Added ability to draw non-expanding headers
   If ((m_bUseExplorerTheme) And (pc.CanExpand)) Then

      ' This part of the routine is only called under
      ' XP

      GetObjectAPI m_hDib(iIndex), Len(tBmp), tBmp
      lhBmpOld = SelectObject(m_hDC, m_hDib(iIndex))
      If (tBmp.bmBitsPixel < 32) Then
         TransparentBlt lHDC, _
            tR.left, tR.Top, tR.right - tR.left, tR.bottom - tR.Top, _
            m_hDC, _
            0, 0, tBmp.bmWidth, tBmp.bmHeight, _
            GetPixelAPI(m_hDC, 0, 0)
      Else
         bf.BlendOp = AC_SRC_OVER
         bf.BlendFlags = 0
         bf.SourceConstantAlpha = 255
         bf.AlphaFormat = AC_SRC_ALPHA
         CopyMemory lBlend, bf, 4
         
         AlphaBlend lHDC, _
            tR.left, tR.Top, tR.right - tR.left, tR.bottom - tR.Top, _
            m_hDC, _
            0, 0, tBmp.bmWidth, tBmp.bmHeight, _
            lBlend
      End If
      SelectObject m_hDC, lhBmpOld
   
   Else
      
      Dim cMemDC As New pcAlphaDibSection
      Dim hBr As Long
      Dim hPen As Long
      Dim hPenOld As Long
      Dim tJunk As POINTAPI
      Dim tWorkR As RECT
      Dim tBackR As RECT
      Dim lColorStart As Long
      Dim lColorEnd As Long
      
      LSet tWorkR = tR
      OffsetRect tWorkR, -tWorkR.left, -tWorkR.Top
      cMemDC.Create tR.right - tR.left, tR.bottom - tR.Top
            
      Dim tbm As BITMAP
      GetObjectAPI m_hDib(0), Len(tbm), tbm
      
      If (pc.CanExpand) Then
         Select Case iIndex
         Case 8 ' special background
            If (pc.TitleBackColorDark = CLR_INVALID) Then
               lColorStart = vbActiveTitleBar
            Else
               lColorStart = pc.TitleBackColorDark
            End If
            If (pc.TitleBackColorLight = CLR_INVALID) Then
               lColorEnd = GetSysColor(COLOR_GRADIENTACTIVECAPTION)
            Else
               lColorEnd = pc.TitleBackColorLight
            End If
            
         Case 9 ' normal background
            If (pc.TitleBackColorDark = CLR_INVALID) Then
               lColorStart = vbWindowBackground
            Else
               lColorStart = pc.TitleBackColorDark
            End If
            If (pc.TitleBackColorLight = CLR_INVALID) Then
               lColorEnd = GetSysColor(COLOR_GRADIENTINACTIVECAPTION)
            Else
               lColorEnd = pc.TitleBackColorLight
            End If
         
         End Select
         
         LSet tBackR = tWorkR
         tBackR.right = tWorkR.right - 2 - tbm.bmWidth
         GradientFillRect cMemDC.hdc, tBackR, lColorStart, lColorEnd,
          GRADIENT_FILL_RECT_H
         
         hBr = CreateSolidBrush(TranslateColor(lColorEnd))
         tBackR.left = tBackR.right
         tBackR.right = tWorkR.right
         FillRect cMemDC.hdc, tBackR, hBr
         DeleteObject hBr
      
      Else
         ' 2003-07-05: Draw top of panel when it can't be expanded:
         If (pc.PanelBackColor = -1) Then
            hBr =
             CreateSolidBrush(TranslateColor(DefaultPanelColor(pc.IsSpecial)))
         Else
            hBr = CreateSolidBrush(TranslateColor(pc.PanelBackColor))
         End If
         FillRect cMemDC.hdc, tWorkR, hBr
         DeleteObject hBr
         
         hPen = CreatePen(PS_SOLID, 1, &HFFFFFF)
         hPenOld = SelectObject(cMemDC.hdc, hPen)
         
         MoveToEx cMemDC.hdc, tR.left, tR.bottom, tJunk
         LineTo cMemDC.hdc, tR.left, tR.Top - 2
         SetPixel cMemDC.hdc, tR.left + 1, tR.Top - 1, &HFFFFFF
         MoveToEx cMemDC.hdc, tR.right - 1, tR.bottom, tJunk
         LineTo cMemDC.hdc, tR.right - 1, tR.Top - 2
         SetPixel cMemDC.hdc, tR.right - 2, tR.Top - 1, &HFFFFFF
         MoveToEx cMemDC.hdc, tR.left + 2, tR.Top, tJunk
         LineTo cMemDC.hdc, tR.right - 3, tR.Top
         
         SelectObject cMemDC.hdc, hPenOld
         DeleteObject hPen
      
      End If
      
      ' 2003-07-05: TransparentBlt leaked GDI under Win98, also
      ' it isn't supported on Win95 or NT4. Replaced
      ' with a sequence of Blts instead:
      cMemDC.PaintPicture lHDC, tR.left + 2, tR.Top, _
         tWorkR.right - tWorkR.left - 4, 1, 2
      cMemDC.PaintPicture lHDC, tR.left + 1, tR.Top + 1, _
         tWorkR.right - tWorkR.left - 2, 1, 1, 1
      cMemDC.PaintPicture lHDC, tR.left, tR.Top + 2, _
         , tWorkR.bottom - tWorkR.Top - 2, 0, 2
      
      'SetPixel cMemDC.hdc, tWorkR.left, tWorkR.Top, &HF1FE02
      'SetPixel cMemDC.hdc, tWorkR.left + 1, tWorkR.Top, &HF1FE02
      'SetPixel cMemDC.hdc, tWorkR.left, tWorkR.Top + 1, &HF1FE02
      'SetPixel cMemDC.hdc, tWorkR.right - 1, tWorkR.Top, &HF1FE02
      'SetPixel cMemDC.hdc, tWorkR.right - 1, tWorkR.Top + 1, &HF1FE02
      'SetPixel cMemDC.hdc, tWorkR.right - 2, tWorkR.Top, &HF1FE02
      '
      'TransparentBlt lHDC, tR.left, tR.Top, tWorkR.right - tWorkR.left,
       tWorkR.bottom - tWorkR.Top, _
      '   cMemDC.hdc, 0, 0, tWorkR.right - tWorkR.left, tWorkR.bottom -
       tWorkR.Top, _
      '   &HF1FE02
   
   End If
   
End Sub
      

Private Sub pMeasure()
Dim pc As pcExplorerBar
Dim hTheme As Long
Dim lHDC As Long
Dim tR As RECT
Dim tTextR As RECT
Dim tSize As SIZEAPI
Dim lTop As Long
Dim hRes As Long
Dim bReEval As Boolean
Dim iItem As Long
Dim iItemTop As Long
Dim itm As pcExplorerBarItem
Dim hFont As Long
Dim hFontOld As Long
Dim bFirstBar As Boolean
Static s_lastWidth As Long
Dim bResized As Boolean
Dim lStart As Long
Dim lMaxBarHeight As Long
Dim sMeasureText As String
Dim lMeasureStyle As Long
Dim tBmp As BITMAP
   
   If Not m_colBars Is Nothing Then
      
      hTheme = plGetTheme()
         
      lHDC = UserControl.hdc
      GetClientRect UserControl.hWnd, tR
      
      Do ' Maximum number of loops around is 2; occurs when scroll bar visible
       changes
         bFirstBar = True
         lTop = tR.Top
         lStart = lTop
         For Each pc In m_colBars
            If (bFirstBar Or m_eStyle = eDefaultStyle) Then
               lTop = lTop + m_lBarSpacing
               bFirstBar = False
            End If
            pc.Top = lTop
            
            If (pc.CanExpand) Or Len(pc.Title) > 0 Then
               If (m_cScrollBar.Visible(efsVertical)) Then
                  lTop = lTop + pc.TitleHeightWithScroll
               Else
                  lTop = lTop + pc.TitleHeightWithoutScroll
               End If
            Else
               ' don't need to add the title height
               lTop = lTop + 16
            End If
            
            If (pc.Expanding Or pc.Collapsing) Then
               lTop = lTop + pc.Height
            ElseIf (pc.State = eBarExpanded) Then
               If (m_cScrollBar.Visible(efsVertical)) Then
                  lTop = lTop + pc.HeightWithScroll
               Else
                  lTop = lTop + pc.HeightWithoutScroll
               End If
            End If
            
            iItemTop = 6
            For iItem = 1 To pc.ItemCount
               Set itm = pc.Item(iItem)
               itm.Top = iItemTop
               If (m_cScrollBar.Visible(efsVertical)) Then
                  iItemTop = iItemTop + itm.HeightWithScroll + itm.SpacingAfter
               Else
                  iItemTop = iItemTop + itm.HeightWithoutScroll +
                   itm.SpacingAfter
               End If
            Next iItem
            
         Next
         lTop = lTop + m_lBarSpacing
         bReEval = False
         
         If (lTop - lStart > lMaxBarHeight) Then
            lMaxBarHeight = lTop - lStart
         End If
         
         If (lTop > tR.bottom - tR.Top) Then
            If Not (m_cScrollBar.Visible(efsVertical)) Then
               m_cScrollBar.Visible(efsVertical) = True
               pResizeContainedControls
               bResized = True
               bReEval = True
            End If
            m_cScrollBar.Max(efsVertical) = lTop - (tR.bottom - tR.Top)
            m_cScrollBar.LargeChange(efsVertical) = tR.bottom - tR.Top
         Else
            If (m_cScrollBar.Visible(efsVertical)) Then
               m_cScrollBar.Visible(efsVertical) = False
               pResizeContainedControls
               bResized = True
               bReEval = True
            End If
         End If
      Loop While bReEval
      
      
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
      
      If Not ((tR.right - tR.left) = s_lastWidth) Then
         s_lastWidth = tR.right - tR.left
         If Not bResized Then
            pResizeContainedControls
         End If
      End If
      
   End If
   
   If (lMaxBarHeight > m_cDibFade.Height) Then
      m_cDibFade.Create m_cDibFade.Width, lMaxBarHeight
   End If
   
End Sub

Private Sub pResizeContainedControls()
Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim iItem As Long

   For Each pc In m_colBars
      For iItem = 1 To pc.ItemCount
         Set itm = pc.Item(iItem)
         If (itm.ItemType = eItemControlPlaceHolder) Then
            pResizeContainedControl pc, itm
         End If
      Next iItem
   Next
End Sub
Private Sub pResizeContainedControl( _
      pc As pcExplorerBar, _
      itm As pcExplorerBarItem _
   )
Dim tR As RECT
Dim lOffset As Long
Dim lTitleHeight As Long
   If Not (itm.lPtrPanel = 0) Then
      If (m_cScrollBar.Visible(efsVertical)) Then
         lOffset = -m_cScrollBar.Value(efsVertical)
         lTitleHeight = pc.TitleHeightWithScroll
      Else
         lTitleHeight = pc.TitleHeightWithoutScroll
      End If
      GetClientRect UserControl.hWnd, tR
      Dim ctl As Control
      Set ctl = ObjectFromPtr(itm.lPtrPanel)
      ctl.Move _
         UserControl.ScaleX(m_lMargin + m_lMargin, vbPixels,
          UserControl.ScaleMode), _
         UserControl.ScaleY(lOffset + pc.Top + itm.Top + lTitleHeight,
          vbPixels, UserControl.ScaleMode), _
         UserControl.ScaleX(tR.right - tR.left - m_lMargin * 4, vbPixels,
          UserControl.ScaleMode)
      ctl.Visible = (pc.State = eBarExpanded) Or (pc.Expanding)
   End If
   
End Sub

Private Function pbHitTest( _
      ByRef pc As pcExplorerBar, _
      pcSel As pcExplorerBar, _
      itmSel As pcExplorerBarItem _
   ) As Boolean
Dim lOffset As Long
Dim tP As POINTAPI
Dim iItem As Long
Dim tR As RECT
Dim tTestR As RECT
Dim itm As pcExplorerBarItem
Dim lItemHeight As Long

   ' Are we inside this bar?
   If (m_cScrollBar.Visible(efsVertical)) Then
      lOffset = -m_cScrollBar.Value(efsVertical)
   End If
   
   GetCursorPos tP
   ScreenToClient UserControl.hWnd, tP
   GetClientRect UserControl.hWnd, tR
   
   tR.Top = pc.Top + lOffset
   If (pc.CanExpand) Or (Len(pc.Title) > 0) Then
      If (m_cScrollBar.Visible(efsVertical)) Then
         tR.bottom = tR.Top + pc.TitleHeightWithScroll
      Else
         tR.bottom = tR.Top + pc.TitleHeightWithoutScroll
      End If
   Else
      tR.bottom = tR.Top
   End If
   tR.left = tR.left + m_lMargin
   tR.right = tR.right - m_lMargin
   
   If Not (PtInRect(tR, tP.x, tP.y) = 0) Then
      ' inside the bar title:
      Set pcSel = pc
      pbHitTest = True
   Else
      If (pc.State = eBarExpanded) Then
         ' check all the items within the bar:
         tR.Top = tR.bottom
         For iItem = 1 To pc.ItemCount
            LSet tTestR = tR
            Set itm = pc.Item(iItem)
            If (itm.ItemType = eItemLink) And (itm.CanClick) Then
               tTestR.Top = tTestR.Top + itm.Top
               If (m_cScrollBar.Visible(efsVertical)) Then
                  lItemHeight = itm.HeightWithScroll
               Else
                  lItemHeight = itm.HeightWithoutScroll
               End If
               tTestR.bottom = tTestR.Top + lItemHeight
               If Not (PtInRect(tTestR, tP.x, tP.y) = 0) Then
                  Set itmSel = itm
                  pbHitTest = True
               End If
            End If
         Next iItem
      End If
   End If
      
End Function

Private Sub pSetMousePointer(ByVal ePointer As MousePointerConstants)
   If Not (ePointer = m_ePointer) Then
      UserControl.MousePointer = ePointer
      m_ePointer = ePointer
   End If
End Sub

Private Sub pSetToolTipText(ByVal sToolTip As String)
   'Debug.Print sToolTip, m_sToolTip
   If Not (StrComp(m_sToolTip, sToolTip) = 0) Then
      'Debug.Print StrComp(m_sToolTip, sToolTip)
      UserControl.Extender.ToolTipText = sToolTip
      m_sToolTip = sToolTip
   End If
End Sub

Private Sub OnBarRightClick(pc As pcExplorerBar)
   Dim cB As New cExplorerBar
   cB.fInit UserControl.hWnd, pc.ID
   RaiseEvent BarRightClick(cB)
End Sub
Private Sub OnBarClick(pc As pcExplorerBar)

   ' Select the bar:
   If Not (m_lIdSelBar = pc.ID) Then
      m_lIdSelItem = 0
      m_lIdSelBar = pc.ID
      pPaint
      UserControl.Refresh
   End If
   
   ' Is this an expandable bar?
   If (pc.CanExpand) Then
      If (pc.State = eBarCollapsed) Then
         ' we want to expand the bar:
         fExpandBar pc, 1
      Else
         ' we want to collapse the bar:
         fExpandBar pc, -1
      End If
   End If

   ' Raise the event:
   Dim cB As New cExplorerBar
   cB.fInit UserControl.hWnd, pc.ID
   RaiseEvent BarClick(cB)
   
End Sub
Private Sub OnItemRightClick(itm As pcExplorerBarItem)

   ' Raise the event
   Dim cI As New cExplorerBarItem
   cI.fInit UserControl.hWnd, itm.BarID, itm.ID
   RaiseEvent ItemRightClick(cI)

End Sub
Private Sub OnItemClick(itm As pcExplorerBarItem)
   
   ' Select the item:
   If Not (m_lIdSelItem = itm.ID) Then
      m_lIdSelItem = itm.ID
      m_lIdSelBar = 0
      pPaint
      UserControl.Refresh
   End If
   
   ' Raise the event
   Dim cI As New cExplorerBarItem
   cI.fInit UserControl.hWnd, itm.BarID, itm.ID
   RaiseEvent ItemClick(cI)
   
End Sub
Private Sub OnHighlight(pc As pcExplorerBar, itm As pcExplorerBarItem)
Static pcLast As pcExplorerBar
Static itmLast As pcExplorerBarItem
Dim cBar As cExplorerBar
Dim cItem As cExplorerBarItem
   
   If Not (itm Is Nothing) Then
      Set pc = m_colBars("C:" & itm.BarID)
      Set cItem = New cExplorerBarItem
      cItem.fInit UserControl.hWnd, pc.ID, itm.ID
   End If
   If Not (pc Is Nothing) Then
      Set cBar = New cExplorerBar
      cBar.fInit UserControl.hWnd, pc.ID
   End If

   If (pcLast Is Nothing) Then
      If Not (pc Is Nothing) Then
         ' Highlight change:
         RaiseEvent Highlight(cBar, cItem)
      End If
   Else
      ' Last item not nothing:
      If (pc Is Nothing) Then
         ' Nothing highlighted:
         RaiseEvent Highlight(Nothing, Nothing)
      Else
         ' Is this the same bar?
         If Not (pc Is pcLast) Then
            ' no
            RaiseEvent Highlight(cBar, cItem)
         Else
            ' same bar, may be a different item:
            If (itmLast Is Nothing) Then
               If Not (itm Is Nothing) Then
                  RaiseEvent Highlight(cBar, cItem)
               End If
            Else
               If Not (itmLast Is itm) Then
                  RaiseEvent Highlight(cBar, cItem)
               End If
            End If
         End If
      End If
   End If
         
   Set pcLast = pc
   Set itmLast = itm

End Sub

Private Function plGetTheme() As Long
   If (IsXp And m_bUseExplorerTheme) Then
      ' Check if there's a theme currently in effect for this:
      On Error Resume Next
      plGetTheme = OpenThemeData(UserControl.hWnd, StrPtr("ExplorerBar"))
   End If
End Function

Private Function pbColouriseWatermarks() As Boolean
   
   Dim pc As pcExplorerBar

   If Not m_colBars Is Nothing Then
      
      For Each pc In m_colBars
         pc.ColouriseWatermark Me
      Next
      
   End If
   
End Function

Private Function pbCreateBitmapWorkDC() As Boolean
Dim lhDCD As Long
Dim lhWndD As Long

   If Not (m_hDC = 0) Then
      DeleteDC m_hDC
   End If

   lhWndD = GetDesktopWindow()
   lhDCD = GetDC(lhWndD)
   m_hDC = CreateCompatibleDC(lhDCD)
   ReleaseDC lhWndD, lhDCD ' 2003-07-05: Corrected for GDI leak in Win98
   
   pbCreateBitmapWorkDC = (m_hDC <> 0)
   
End Function

Private Function pbLoadShellStyleBitmaps() As Boolean
Dim hTheme As Long
Dim hRes As Long
Dim iPos As Long
Dim lPtrColorName As Long
Dim lPtrThemeFile As Long
Dim sThemeFile As String
Dim sColorName As String
Dim sShellStyle As String
Dim hLib As Long
Dim i As Long
Dim bFail As Boolean
Dim lhBmpOld As Long
Dim tR As RECT

   For i = 0 To 10
      If Not (m_hDib(i) = 0) Then
         DeleteObject m_hDib(i)
      End If
   Next i

   hTheme = plGetTheme()
   
   If Not (hTheme = 0) Then
   
      ReDim bThemeFile(0 To 260 * 2) As Byte
      lPtrThemeFile = VarPtr(bThemeFile(0))
      ReDim bColorName(0 To 260 * 2) As Byte
      lPtrColorName = VarPtr(bColorName(0))
      hRes = GetCurrentThemeName(lPtrThemeFile, 260, lPtrColorName, 260, 0, 0)
      
      sThemeFile = bThemeFile
      iPos = InStr(sThemeFile, vbNullChar)
      If (iPos > 1) Then sThemeFile = left(sThemeFile, iPos - 1)
      sColorName = bColorName
      iPos = InStr(sColorName, vbNullChar)
      If (iPos > 1) Then sColorName = left(sColorName, iPos - 1)
      
      sShellStyle = sThemeFile
      For iPos = Len(sThemeFile) To 1 Step -1
         If (Mid(sThemeFile, iPos, 1) = "\") Then
            sShellStyle = left(sThemeFile, iPos)
            Exit For
         End If
      Next iPos
      sShellStyle = sShellStyle & "Shell\" & sColorName & "\shellstyle.dll"
      If (FileExists(sShellStyle)) Then
         hLib = LoadLibraryEx(sShellStyle, 0, LOAD_LIBRARY_AS_DATAFILE)
         If Not (hLib = 0) Then
            
            m_hDib(0) = LoadImageLong(hLib, 100, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(1) = LoadImageLong(hLib, 101, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(2) = LoadImageLong(hLib, 102, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(3) = LoadImageLong(hLib, 103, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(4) = LoadImageLong(hLib, 104, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(5) = LoadImageLong(hLib, 105, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(6) = LoadImageLong(hLib, 106, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(7) = LoadImageLong(hLib, 107, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(8) = LoadImageLong(hLib, 110, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(9) = LoadImageLong(hLib, 112, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            m_hDib(10) = LoadImageLong(hLib, 14, IMAGE_BITMAP, 0, 0,
             LR_CREATEDIBSECTION)
            
            For i = 0 To 10
               If (m_hDib(i) = 0) Then
                  bFail = True
               End If
            Next i
            
            FreeLibrary hLib
            
            If Not bFail Then
               lhBmpOld = SelectObject(m_hDC, m_hDib(10))
               m_lThemePanelColor = GetPixelAPI(m_hDC, 0, 0)
               SelectObject m_hDC, lhBmpOld
            End If
            
            pbLoadShellStyleBitmaps = Not (bFail)
            
         End If
      End If
      
      CloseThemeData hTheme
      
   Else
      m_lThemePanelColor = BlendColor(vbButtonFace, &HFFFFFF, 24)

      ' Backgrounds (i.e. m_hDib(8) and m_hDib(9)) are drawn on the fly
      ' so no need to define them.
      
      ' Remember that the colours of the icons may change if the user
      ' customises the bar title colours later on, so a separate fn
      ' is used.
      pLoadColourisedFakeShellStyleBitmaps
            
      pbLoadShellStyleBitmaps = True
   End If
      
End Function

Private Sub pLoadColourisedFakeShellStyleBitmaps()
Dim lColorDarkSpecial As Long
Dim lColorDarkNormal As Long
Dim pc As pcExplorerBar
   
   ' Determine the titlebar dark colours:
   lColorDarkSpecial = CLR_INVALID
   lColorDarkNormal = CLR_INVALID
   For Each pc In m_colBars
      If (pc.IsSpecial) And (lColorDarkSpecial = CLR_INVALID) Then
         If (pc.TitleBackColorDark = CLR_INVALID) Then
            lColorDarkSpecial = GetSysColor(COLOR_GRADIENTACTIVECAPTION)
         Else
            lColorDarkSpecial = pc.TitleBackColorLight
         End If
      ElseIf (lColorDarkNormal = CLR_INVALID) Then
         If (pc.TitleBackColorDark = CLR_INVALID) Then
            lColorDarkNormal = GetSysColor(COLOR_GRADIENTINACTIVECAPTION)
         Else
            lColorDarkNormal = pc.TitleBackColorLight
         End If
      End If
   Next
   If (lColorDarkSpecial = CLR_INVALID) Then
      lColorDarkSpecial = GetSysColor(COLOR_GRADIENTACTIVECAPTION)
   End If
   If (lColorDarkNormal = CLR_INVALID) Then
      lColorDarkNormal = GetSysColor(COLOR_GRADIENTINACTIVECAPTION)
   End If
   
   ' Now create some bitmaps:
   
   Dim cGlyph As New pcAlphaDibSection
   Dim sPic As StdPicture
   
   ' Normal Collapse:
   Set sPic = LoadResPicture(101, vbResBitmap)
   cGlyph.CreateFromPicture sPic
   ColouriseGlyph cGlyph, lColorDarkNormal
   DeleteObject m_hDib(0)
   m_hDib(0) = cGlyph.ExtractDib
   m_hDib(1) = m_hDib(0)
   
   ' Normal Expand:
   Set sPic = LoadResPicture(102, vbResBitmap)
   cGlyph.CreateFromPicture sPic
   ColouriseGlyph cGlyph, lColorDarkNormal
   DeleteObject m_hDib(2)
   m_hDib(2) = cGlyph.ExtractDib
   m_hDib(3) = m_hDib(2)
   
   ' Special Collapse:
   Set sPic = LoadResPicture(103, vbResBitmap)
   cGlyph.CreateFromPicture sPic
   ColouriseGlyph cGlyph, lColorDarkSpecial
   DeleteObject m_hDib(4)
   m_hDib(4) = cGlyph.ExtractDib
   m_hDib(5) = m_hDib(4)
   
   ' Special Expand:
   Set sPic = LoadResPicture(104, vbResBitmap)
   cGlyph.CreateFromPicture sPic
   ColouriseGlyph cGlyph, lColorDarkSpecial
   DeleteObject m_hDib(6)
   m_hDib(6) = cGlyph.ExtractDib
   m_hDib(7) = m_hDib(6)
      
End Sub

Private Sub pInitialise()
   '
   m_bRunTime = UserControl.Ambient.UserMode
   If (m_bRunTime) Then
      
      VerInitialise
      
      ' 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_ptrOnMnemonicOrig = ReplaceVTableEntry( _
         ObjPtr(IOleCtl), _
         IDX_OnMnemonic, _
         AddressOf mIOleControl.IOleControl_OnMnemonic, _
         ObjPtr(Me) _
         )
         
      ' Create object to manage Mnemonics for this control:
      Set m_cMnemonics = New pcMnemonics
      
      ' For tab trapping & settings changes:
      m_hWnd = UserControl.hWnd
      Dim lhWnd As Long
      Dim sBuf As String
      lhWnd = m_hWnd
      Do
         lhWnd = GetParent(lhWnd)
         If Not (lhWnd = 0) Then
            'sBuf = String$(255, 0)
            'GetClassName lhWnd, sBuf, 255
            'If (InStr(sBuf, "Main") = 0) Then ' ThunderMain window
               m_hWndContainer = lhWnd
            'Else
            '   lhWnd = 0
            'End If
         End If
      Loop While Not (lhWnd = 0)
      
      AttachMessage Me, m_hWnd, WM_SETFOCUS
      AttachMessage Me, m_hWndContainer, WM_SETTINGCHANGE
      
      Set m_cScrollBar = New pcScrollBars
      m_cScrollBar.Create UserControl.hWnd
      m_cScrollBar.Orientation = efsoVertical
      m_cScrollBar.Visible(efsVertical) = False
      m_cScrollBar.Visible(efsHorizontal) = False
      m_cScrollBar.SmallChange(efsVertical) = 12
      
      Set m_tmr = New CTimer
      
      SetProp UserControl.hWnd, "VBALEXPLORERBARCTL", ObjPtr(Me)
      
      Set m_colBars = New Collection
      Set m_colBarKeys = New Collection
      Set m_colItems = New Collection
      
      ' Load theme if required:
      pbCreateBitmapWorkDC
      If (IsXp And m_bUseExplorerTheme) Or (Not (m_bUseExplorerTheme)) Then
         If Not (pbLoadShellStyleBitmaps()) Then
            ' If we can't load the shell style DLL then we're stuffed
            m_bUseExplorerTheme = False
            pbLoadShellStyleBitmaps
         End If
      End If
         
      Set m_cNCM = New pcNCMetrics
      m_cNCM.GetMetrics
      
      Set UserControl.MouseIcon = LoadResPicture("HAND", vbResCursor)
      
   End If
   '
End Sub
Private Sub pTerminate()
   '
   ' Perform any clear up we need here
   RemoveProp UserControl.hWnd, "VBALEXPLORERBARCTL"
   Set m_cScrollBar = Nothing
   Set m_cDibFade = Nothing
   
   Dim i As Long
   For i = 0 To 10
      If Not (m_hDib(i) = 0) Then
         DeleteObject m_hDib(i)
         m_hDib(i) = 0
      End If
   Next i
   
   If Not (m_hDC = 0) Then
      DeleteDC m_hDC
      m_hDC = 0
   End If
   
   If Not (m_ptrGetControlInfoOrig = 0) Then
   
      ' Get the IOLEControl interface of the control
      Dim IOleCtl As IOleControl
      Set IOleCtl = Me
      ' Restore IOleControl methods:
      ReplaceVTableEntry _
         ObjPtr(IOleCtl), _
         IDX_GetControlInfo, _
         m_ptrGetControlInfoOrig
      m_ptrGetControlInfoOrig = 0
   End If
   
   If Not (m_ptrOnMnemonicOrig = 0) Then
      ReplaceVTableEntry _
         ObjPtr(IOleCtl), _
         IDX_OnMnemonic, _
         m_ptrOnMnemonicOrig
      m_ptrOnMnemonicOrig = 0
   End If
      
   If Not (m_hWnd = 0) Then
      DetachMessage Me, m_hWnd, WM_SETFOCUS
      DetachMessage Me, m_hWndContainer, WM_SETTINGCHANGE
      m_hWnd = 0
      m_hWndContainer = 0
   End If
   
   '
End Sub

Private Function piKeyStringToKeyCode(ByVal sKey As String) As Integer
Dim b() As Byte
Dim vKey As Integer
   
   If (GetVersion() And &H80000000) = 0 Then
      ' NT
      b = sKey
      CopyMemory vKey, b(0), 2
      vKey = VkKeyScanW(vKey)
   Else
      ' 9x
      b = StrConv(sKey, vbFromUnicode)
      vKey = VkKeyScan(b(0))
   End If
   piKeyStringToKeyCode = vKey And &HFF&
   
End Function
Private Sub pFireMnemonic(ByVal sKey As String)
Dim bClicked As Boolean

   ' Check all the bars:
   Dim pc As pcExplorerBar
   For Each pc In m_colBars
      If (pc.HasMnemonic(sKey)) Then
         OnBarClick pc
         bClicked = True
         Exit For
      End If
   Next
   
   If Not (bClicked) Then
   
      ' Check all the items:
      Dim itm As pcExplorerBarItem
      For Each itm In m_colItems
         If (itm.HasMnemonic(sKey)) Then
            OnItemClick itm
            Exit For
         End If
      Next
      
   End If
   
End Sub
Private Sub pFindNextItem( _
      ByRef lIDBar As Long, _
      ByRef lIDItem As Long, _
      ByVal iDir As Long, _
      ByVal bTab As Boolean _
   )
Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim i As Long, j As Long
Dim bFound As Boolean
Dim lBarIndex As Long
Dim lBarStart As Long
Dim lItemIndex As Long
Dim lItemStart As Long
Dim lItemEnd As Long
Dim bFirst As Boolean
   
   lIDBar = 0
   lIDItem = 0
   
   If (m_lIdSelBar > 0) Then
      If Not (fVerifyId(m_lIdSelBar, 1)) Then
         m_lIdSelBar = 0
      End If
   End If
   If (m_lIdSelItem > 0) Then
      If Not (fVerifyId(m_lIdSelItem, 2)) Then
         m_lIdSelItem = 0
      End If
   End If
   
   If (m_lIdSelBar = 0) And (m_lIdSelItem = 0) Then
      ' nothing selected:
      If (iDir < 0) Then
         
         ' pick the last accessible item in the control
         For i = m_colBars.Count To 1 Step -1
            Set pc = m_colBars(i)
            If (pc.State = eBarExpanded) Then
               For j = pc.ItemCount To 1 Step -1
                  Set itm = pc.Item(j)
                  If (itm.CanClick And itm.ItemType = eItemLink) Or
                   (itm.lPtrPanel > 0) Then
                     lIDItem = itm.ID
                     bFound = True
                     Exit For
                  End If
               Next j
            End If
            If (bFound) Then
               Exit For
            Else
               If (pc.CanExpand) Then
                  lIDBar = pc.ID
                  Exit For
               End If
            End If
         Next i
         
      Else
         
         ' pick the first accessible item in the control
         For i = 1 To m_colBars.Count
            Set pc = m_colBars(i)
            If (pc.CanExpand) Then
               lIDBar = pc.ID
               Exit For
            Else
               If (pc.State = eBarExpanded) Then
                  For j = 1 To pc.ItemCount
                     Set itm = pc.Item(j)
                     If (itm.CanClick And itm.ItemType = eItemLink) Or
                      (itm.lPtrPanel > 0) Then
                        lIDItem = itm.ID
                        bFound = True
                        Exit For
                     End If
                  Next j
               End If
            End If
            If (bFound) Then
               Exit For
            End If
         Next i
      End If
   
   Else
      
      ' First find the selected item:
      For i = m_colBars.Count To 1 Step -1
         Set pc = m_colBars(i)
         lBarIndex = i
         For j = pc.ItemCount To 1 Step -1
            Set itm = pc.Item(j)
            If (itm.ID = m_lIdSelItem) Then
               lItemIndex = j
               bFound = True
               Exit For
            End If
         Next j
         If (bFound) Or (pc.ID = m_lIdSelBar) Then
            Exit For
         End If
      Next i
      bFound = False
      bFirst = True
      
      
      ' Now determine the next item to be
      ' selected:
      If (iDir < 0) Then
         
         ' Looking for the prior item:
         If (lItemIndex > 0) Then
            lBarStart = lBarIndex
         Else
            lBarStart = lBarIndex - 1
         End If
         
         For i = lBarStart To 1 Step -1
            
            Set pc = m_colBars(i)
            If (pc.State = eBarExpanded) Then
            
               lItemStart = pc.ItemCount
               If (bFirst) Then
                  If (lItemIndex > 0) Then
                     lItemStart = lItemIndex - 1
                     If (bTab) Then
                        lItemStart = 0
                     End If
                  End If
               End If
               
               If (lItemStart > 0) Then
                  For j = lItemStart To 1 Step -1
                     Set itm = pc.Item(j)
                     If (itm.CanClick And itm.ItemType = eItemLink) Or
                      (itm.lPtrPanel > 0) Then
                        lIDItem = itm.ID
                        bFound = True
                        Exit For
                     End If
                  Next j
               End If
            End If
            
            If (bFound) Then
               Exit For
            Else
               If (pc.CanExpand) Then
                  lIDBar = pc.ID
                  Exit For
               End If
            End If
            bFirst = False
            
         Next i
         
      Else
         
         ' Looking for the next item:
         lBarStart = lBarIndex
         
         ' Check if the next thing to select
         ' is the next bar along:
         Set pc = m_colBars(lBarStart)
         If (bTab) Or (lItemIndex = pc.ItemCount) Or (pc.State = eBarCollapsed)
          Then
            ' next item is a bar:
            If (lBarStart < m_colBars.Count) Then
               Set pc = m_colBars(lBarStart + 1)
               lIDBar = pc.ID
               bFound = True
            End If
         End If
         
         If Not (bFound) Then
                     
            For i = lBarStart To m_colBars.Count
               
               Set pc = m_colBars(i)
               
               lItemStart = 1
               If (bFirst) Then
               
                  If (lItemIndex > 0) Then
                     lItemStart = lItemIndex + 1
                     If (bTab) Then
                        lItemStart = pc.ItemCount + 1
                     End If
                  End If
               End If
               
               If (lItemStart <= pc.ItemCount) Then
                  If (pc.State = eBarExpanded) Then
                     For j = lItemStart To pc.ItemCount
                        Set itm = pc.Item(j)
                        If (itm.CanClick And itm.ItemType = eItemLink) Or
                         (itm.lPtrPanel > 0) Then
                           lIDItem = itm.ID
                           bFound = True
                           Exit For
                        End If
                     Next j
                  End If
               End If
            
               If (bFound) Then
                  Exit For
               Else
                  If Not (bFirst) Or (lItemIndex = 0) Then
                     If (pc.CanExpand) Then
                        lIDBar = pc.ID
                        Exit For
                     End If
                  End If
               End If
               bFirst = False
               
            Next i
         
         End If
         
      End If
   
   End If
   
   If Not bTab Then
      If (lIDBar = 0) And (lIDItem = 0) Then
         lIDBar = m_lIdSelBar
         lIDItem = m_lIdSelItem
      End If
   Else
      If (lIDBar = m_lIdSelBar) And (lIDItem = m_lIdSelItem) Then
         lIDBar = 0
         lIDItem = 0
      End If
   End If
   
End Sub

Private Function pKeyDown(KeyCode As Integer, Shift As Integer) As Boolean
Dim lIDBar As Long
Dim lIDItem As Long
Dim iDir As Long
Dim bTab As Boolean
Dim bProcess As Boolean
Dim pc As pcExplorerBar
Dim i As Long
Dim lPageSize As Long
Dim tR As RECT
   
   If Not (m_colBars Is Nothing) Then
   If (m_colBars.Count > 0) Then
   
   ' Tab key processing:
   Select Case KeyCode
      Case vbKeyTab, vbKeyDown, vbKeyUp
         
         Select Case KeyCode
         Case vbKeyTab
            bTab = True
            If ((Shift And vbShiftMask) = vbShiftMask) Then
               iDir = -1
            Else
               iDir = 1
            End If
            bProcess = True
         Case vbKeyDown
            iDir = 1
            bProcess = True
         Case vbKeyUp
            iDir = -1
            bProcess = True
         End Select
         
         If (bProcess) Then
            pFindNextItem lIDBar, lIDItem, iDir, bTab
            m_lIdSelBar = lIDBar
            m_lIdSelItem = lIDItem
         End If
         
      Case vbKeyHome
         bProcess = True
         Set pc = m_colBars(1)
         m_lIdSelBar = pc.ID
         m_lIdSelItem = 0
      
      Case vbKeyEnd
         bProcess = True
         Set pc = m_colBars(m_colBars.Count)
         m_lIdSelBar = pc.ID
         m_lIdSelItem = 0
         If (pc.ItemCount > 0) Then
            If Not (pc.CanExpand) Or (pc.CanExpand And pc.State = eBarExpanded)
             Then
               For i = pc.ItemCount To 1 Step -1
                  If (pc.Item(i).CanClick) And (pc.Item(i).ItemType <>
                   eItemText) Then
                     m_lIdSelItem = pc.Item(pc.ItemCount).ID
                     Exit For
                  End If
               Next i
            End If
         End If
      
      Case vbKeyPageDown, vbKeyPageUp
            
         GetClientRect m_hWnd, tR
         lPageSize = (tR.bottom - tR.Top) \ 2
         
         Select Case KeyCode
         Case vbKeyPageDown
            iDir = 1
         Case vbKeyPageUp
            iDir = -1
         End Select
         
         
            
      
   End Select
      
   If (bProcess) Then
      If (m_lIdSelBar = 0) And (m_lIdSelItem = 0) Then
         pKeyDown = False
      Else
         m_bHaveUsedKeys = True
         If (m_lIdSelItem > 0) Then
            Dim itm As pcExplorerBarItem
            Set itm = m_colItems("C:" & m_lIdSelItem)
            fEnsureItemVisible itm.BarID, m_lIdSelItem
            If (itm.lPtrPanel > 0) Then
               Dim ctl As Control
               Set ctl = ObjectFromPtr(itm.lPtrPanel)
               On Error Resume Next
               ctl.SetFocus
            End If
         ElseIf (m_lIdSelBar > 0) Then
            fEnsureBarVisible m_lIdSelBar
         End If
         pPaint
         UserControl.Refresh
         pKeyDown = True
      End If
      
   End If
   
   End If
   End If
   '
End Function
Private Function pKeyPress(KeyAscii As Integer) As Boolean

End Function
Private Function pKeyUp(KeyCode As Integer, Shift As Integer) As Boolean
   
   Select Case KeyCode
   Case vbKeySpace, vbKeyReturn
      ' like pressing an item:
      If (m_lIdSelItem > 0) Then
         Dim itm As pcExplorerBarItem
         Set itm = m_colItems("C:" & m_lIdSelItem)
         OnItemClick itm
         pKeyUp = True
      ElseIf (m_lIdSelBar > 0) Then
         Dim pc As pcExplorerBar
         Set pc = m_colBars("C:" & m_lIdSelBar)
         OnBarClick pc
         pKeyUp = True
      End If
   End Select
   
End Function


Friend Function GetControlInfo(pCI As CONTROLINFO) As Long
   
   Debug.Print "GetControlInfo"
   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
            pFireMnemonic m_cMnemonics.Key(i)
            Exit For
         End If
      Next i
   End If
   
End Function
Friend Function TranslateAccelerator(lpMsg As VBOleGuids.MSG) As Long
   TranslateAccelerator = S_FALSE
   ' Here you can modify the response to the key down
   ' accelerator command using the values in lpMsg.  This
   ' can be used to capture Tabs, Returns, Arrows etc.
   ' Just process the message as required and return S_OK.
   If (lpMsg.wParam And &HFFFF&) = vbKeyTab Then
      Select Case lpMsg.Message
      Case WM_KEYDOWN
         If (pKeyDown(vbKeyTab, ShiftState)) Then
            TranslateAccelerator = S_OK
         End If
      Case WM_KEYUP
         If (pKeyUp(vbKeyTab, ShiftState)) Then
            TranslateAccelerator = S_OK
         End If
      End Select
   End If
End Function
Private Property Get ShiftState() As Integer
   ' we don't need to consider Alt for a Tab key press.
   ShiftState = IIf(GetAsyncKeyState(vbKeyShift) = 0, 0, 1) * vbShiftMask Or
    IIf(GetAsyncKeyState(vbKeyControl) = 0, 0, 1) * vbCtrlMask
End Property

Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
   ISubclass_MsgResponse = emrPreprocess
End Property

Private Function ISubclass_WindowProc(ByVal hWnd As Long, ByVal iMsg As Long,
 ByVal wParam As Long, ByVal lParam As Long) As Long
   Select Case iMsg
   Case WM_SETTINGCHANGE
      Debug.Print "WM_SETTINGCHANGE"
      
      ' Load theme if required:
      pbCreateBitmapWorkDC
      If (IsXp And m_bUseExplorerTheme) Or (Not (m_bUseExplorerTheme)) Then
         If Not (pbLoadShellStyleBitmaps()) Then
            ' If we can't load the shell style DLL then we're stuffed
            m_bUseExplorerTheme = False
            pbLoadShellStyleBitmaps
         End If
      End If
      pbColouriseWatermarks
      pPaint
      UserControl.Refresh
      RaiseEvent SettingChange
   
   ' --------------------------------------------------------------------------
   ' Required to allow Tab keys to be trapped:
   Case WM_SETFOCUS
      Dim pOleObject                  As VBOleGuids.IOleObject
      Dim pOleInPlaceSite             As VBOleGuids.IOleInPlaceSite
      Dim pOleInPlaceFrame            As VBOleGuids.IOleInPlaceFrame
      Dim pOleInPlaceUIWindow         As VBOleGuids.IOleInPlaceUIWindow
      Dim pOleInPlaceActiveObject     As VBOleGuids.IOleInPlaceActiveObject
      Dim PosRect                     As VBOleGuids.RECT
      Dim ClipRect                    As VBOleGuids.RECT
      Dim FrameInfo                   As VBOleGuids.OLEINPLACEFRAMEINFO
      Dim grfModifiers                As Long
      Dim AcceleratorMsg              As VBOleGuids.MSG
   
      'Get in-place frame and make sure it is set to our in-between
      'implementation of IOleInPlaceActiveObject in order to catch
      'TranslateAccelerator calls
      Set pOleObject = Me
      Set pOleInPlaceSite = pOleObject.GetClientSite
      pOleInPlaceSite.GetWindowContext pOleInPlaceFrame, pOleInPlaceUIWindow,
       VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
      CopyMemory pOleInPlaceActiveObject, m_IPAOHookStruct.ThisPointer, 4
      pOleInPlaceFrame.SetActiveObject pOleInPlaceActiveObject, vbNullString
      If Not pOleInPlaceUIWindow Is Nothing Then
         pOleInPlaceUIWindow.SetActiveObject pOleInPlaceActiveObject,
          vbNullString
      End If
      ' Clear up the inbetween implementation:
      CopyMemory pOleInPlaceActiveObject, 0&, 4
      
      If ((GetAsyncKeyState(vbKeyTab) And &H8000&) = &H8000&) Then
         ' we got here because of a tab press:
         pKeyDown vbKeyTab, ShiftState
      End If
   ' --------------------------------------------------------------------------
      
   End Select
End Function

Private Sub m_cScrollBar_Change(eBar As EFSScrollBarConstants)
   '
   pPaint
   pResizeContainedControls
   UserControl.Refresh
   '
End Sub

Private Sub m_cScrollBar_Scroll(eBar As EFSScrollBarConstants)
   '
   pPaint
   pResizeContainedControls
   UserControl.Refresh
   '
End Sub

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

Private Sub m_tmr_ThatTime()
Dim tR As RECT
Dim tP As POINTAPI
Dim hTheme As Long
Dim pc As pcExplorerBar
   '
   ' Do some checks:
   If Not (m_pcOver Is Nothing) Then
      If Not (fVerifyId(m_pcOver.ID, 1)) Then
         Set m_pcOver = Nothing
      End If
   End If
   If Not (m_itmOver Is Nothing) Then
      If Not (fVerifyId(m_itmOver.ID, 2)) Then
         Set m_itmOver = Nothing
      End If
   End If
   
   GetCursorPos tP
   ScreenToClient UserControl.hWnd, tP
   GetClientRect UserControl.hWnd, tR
   
   If (PtInRect(tR, tP.x, tP.y) = 0) Then
      hTheme = plGetTheme()
   
      If (m_pcOver Is Nothing) Then
         If Not (m_itmOver Is Nothing) Then
            m_itmOver.MouseOver = False
            Set pc = m_colBars("C:" & m_itmOver.BarID)
            pPaintBar pc, UserControl.hdc, hTheme, tR
            pPaintBorders UserControl.hdc, hTheme, tR
         End If
      Else
         m_pcOver.MouseOver = False
         pPaintBar m_pcOver, UserControl.hdc, hTheme, tR
         pPaintBorders UserControl.hdc, hTheme, tR
      End If
      UserControl.Refresh
      
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
      
      m_tmr.Interval = 0
      
   End If
   
   '
End Sub

Private Sub UserControl_GotFocus()
   m_bFocus = True
   If (m_bShowFocusRect) Then
      pPaint
      UserControl.Refresh
   End If
End Sub

Private Sub UserControl_Initialize()
   '
   m_bUseExplorerTheme = True
   m_bUseExplorerTransitionStyle = True
   m_bShowFocusRect = True
   m_bRedraw = True
   
   m_lBarSpacing = 15
   m_lItemSpacing = 1
   m_lMargin = 12
   
   ' Set up information about this control for
   ' IOleInPlaceActiveObject interface:
   Dim IPAO As IOleInPlaceActiveObject

   With m_IPAOHookStruct
      Set IPAO = Me
      CopyMemory .IPAOReal, IPAO, 4
      CopyMemory .TBEx, Me, 4
      .lpVTable = IPAOVTable
      .ThisPointer = VarPtr(m_IPAOHookStruct)
   End With
      
   '
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   '
   pKeyDown KeyCode, Shift
   '
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   '
   pKeyPress KeyAscii
   '
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
   '
   pKeyUp KeyCode, Shift
   '
End Sub

Private Sub UserControl_LostFocus()
   m_bFocus = False
   If (m_bShowFocusRect) Then
      pPaint
      UserControl.Refresh
   End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)

Dim pc As pcExplorerBar
Dim pcSel As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim itmSel As pcExplorerBarItem
Dim tR As RECT
Dim hTheme As Boolean

   '
   If Not (m_colBars Is Nothing) Then
      
      m_tmr.Interval = 0
      
      ' Check if the mouse is down on something:
      For Each pc In m_colBars
         If (pbHitTest(pc, pcSel, itmSel)) Then
            Exit For
         End If
      Next
                        
      If (pcSel Is Nothing) And (itmSel Is Nothing) Then
         Exit Sub
      End If
      
      hTheme = plGetTheme()
                        
      ' Ensure no other item or bar has mouse over
      ' or down:
      For Each pc In m_colBars
         If Not pc Is pcSel Then
            If (pc.MouseDown Or pc.MouseOver) Then
               pc.MouseDown = False
               pc.MouseOver = False
               pPaintBar pc, UserControl.hdc, hTheme, tR, True
               pPaintBorders UserControl.hdc, hTheme, tR
            End If
         End If
      Next
      
      For Each itm In m_colItems
         If Not itm Is itmSel Then
            If (itm.MouseDown Or itm.MouseOver) Then
               itm.MouseDown = False
               itm.MouseOver = False
               Set pc = m_colBars("C:" & itm.BarID)
               pPaintBar pc, UserControl.hdc, hTheme, tR, True
               pPaintBorders UserControl.hdc, hTheme, tR
            End If
         End If
      Next
      
      ' Set this item to have mouse over & down:
      GetClientRect UserControl.hWnd, tR
      If (itmSel Is Nothing) Then
         pcSel.MouseDown = (Button = vbLeftButton)
         pcSel.MouseOver = True
         pPaintBar pcSel, UserControl.hdc, hTheme, tR, True
         If (Button = vbRightButton) Then
            OnBarRightClick pcSel
         End If
      Else
         itmSel.MouseDown = (Button = vbLeftButton)
         itmSel.MouseOver = True
         Set pc = m_colBars("C:" & itmSel.BarID)
         pPaintBar pc, UserControl.hdc, hTheme, tR, True
         pPaintBorders UserControl.hdc, hTheme, tR
         If (Button = vbRightButton) Then
            OnItemRightClick itmSel
         End If
      End If
      
      If Not (hTheme = 0) Then
         CloseThemeData hTheme
      End If
                              
   End If
   '
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)

Dim pc As pcExplorerBar
Dim pcSel As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim itmSel As pcExplorerBarItem
Dim hTheme As Long
Dim tR As RECT
Dim sToolTip As String
Dim ePointer As MousePointerConstants

   '
   If Not (m_colBars Is Nothing) Then
      If (Button = 0) Then
      
         For Each pc In m_colBars
            If (pbHitTest(pc, pcSel, itmSel)) Then
               Exit For
            End If
         Next
         
         GetClientRect UserControl.hWnd, tR
         hTheme = plGetTheme()
         
         For Each pc In m_colBars
            If Not pc Is pcSel Then
               If (pc.MouseDown Or pc.MouseOver) Then
                  pc.MouseDown = False
                  pc.MouseOver = False
                  pPaintBar pc, UserControl.hdc, hTheme, tR, True
                  pPaintBorders UserControl.hdc, hTheme, tR
                  UserControl.Refresh
               End If
            End If
         Next
         
         For Each itm In m_colItems
            If Not itm Is itmSel Then
               If (itm.MouseDown Or itm.MouseOver) Then
                  itm.MouseDown = False
                  itm.MouseOver = False
                  Set pc = m_colBars("C:" & itm.BarID)
                  pPaintBar pc, UserControl.hdc, hTheme, tR, True
                  pPaintBorders UserControl.hdc, hTheme, tR
                  UserControl.Refresh
               End If
            End If
         Next
         
         Set m_pcOver = Nothing
         Set m_itmOver = Nothing
         If (pcSel Is Nothing) And (itmSel Is Nothing) Then
            sToolTip = ""
            ePointer = vbDefault
            m_tmr.Interval = 0
         Else
            m_tmr.Interval = 50
            If Not (pcSel Is Nothing) Then
               ePointer = IIf(pcSel.CanExpand, vbCustom, vbDefault) '
                2003-07-05: Pointer should not be a hand unless the item can be
                expanded
               sToolTip = pcSel.ToolTipText
               pcSel.MouseOver = True
               Set m_pcOver = pcSel
               pPaintBar pcSel, UserControl.hdc, hTheme, tR, True
               pPaintBorders UserControl.hdc, hTheme, tR
               UserControl.Refresh
            Else
               ePointer = vbCustom
               sToolTip = itmSel.ToolTipText
               itmSel.MouseOver = True
               Set m_itmOver = itmSel
               Set pc = m_colBars("C:" & m_itmOver.BarID)
               pPaintBar pc, UserControl.hdc, hTheme, tR, True
               pPaintBorders UserControl.hdc, hTheme, tR
               UserControl.Refresh
            End If
         End If
         
         If (Not (hTheme = 0)) Then
            CloseThemeData hTheme
         End If
         
         pSetToolTipText sToolTip
         pSetMousePointer ePointer
         OnHighlight m_pcOver, m_itmOver
         
      End If
   End If
   '
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As
 Single, y As Single)

Dim pc As pcExplorerBar
Dim itm As pcExplorerBarItem
Dim pcSel As pcExplorerBar
Dim itmSel As pcExplorerBarItem
Dim hTheme As Long
Dim tR As RECT
   
   '
   If (Button = vbLeftButton) Then
      For Each pc In m_colBars
         If (pbHitTest(pc, pcSel, itmSel)) Then
            If (pcSel Is Nothing) Then
               ' Click on item?
               If (itmSel.MouseDown) Then
                  OnItemClick itmSel
               End If
            Else
               ' Click on bar?
               If (pcSel.MouseDown) Then
                  OnBarClick pcSel
               End If
            End If
         End If
      Next
   End If
   
   ' nothing mouse down any more:
   hTheme = plGetTheme()
   GetClientRect UserControl.hWnd, tR
   
   For Each pc In m_colBars
      If (pc.MouseDown) Then
         pc.MouseDown = False
         pPaintBar pc, UserControl.hdc, hTheme, tR, True
         pPaintBorders UserControl.hdc, hTheme, tR
      End If
   Next
   
   If Not (hTheme = 0) Then
      CloseThemeData hTheme
   End If
   '
   
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   UseExplorerStyle = PropBag.ReadProperty("UseExplorerTheme", True)
   UseExplorerTransitionStyle =
    PropBag.ReadProperty("UseExplorerTransitionStyle", True)
   m_oBackColorEnd = PropBag.ReadProperty("BackColorEnd", vbWindowBackground)
   m_oBackColorStart = PropBag.ReadProperty("BackColorStart",
    vbWindowBackground)
   m_bShowFocusRect = PropBag.ReadProperty("ShowFocusRect", True)
   m_bRedraw = PropBag.ReadProperty("Redraw", True)
   
   pInitialise
   '
End Sub

Private Sub UserControl_Resize()
Dim tR As RECT
Dim tWR As RECT
   '
   GetClientRect UserControl.hWnd, tR
   If (m_cDibFade Is Nothing) Then
      Set m_cDibFade = New pcAlphaDibSection
   End If
   If (tR.right - tR.left) > m_cDibFade.Width Or (tR.bottom - tR.Top) >
    m_cDibFade.Height Then
      m_cDibFade.Create tR.right - tR.left, tR.bottom - tR.Top
   End If
   
   If Not (m_colBars Is Nothing) Then
      GetWindowRect UserControl.hWnd, tWR
      If Not ((tWR.right - tWR.left) = m_lLastWidth) Then
         Dim pc As pcExplorerBar
         For Each pc In m_colBars
            fBarChanged pc.ID, True, False
         Next
      End If
            
      pMeasure
   End If
   
   pPaint
   UserControl.Refresh
   '
End Sub

Private Sub UserControl_Show()
   '
   UserControl_Resize
   '
End Sub

Private Sub UserControl_Terminate()
   '
   pTerminate
   
   ' Detach the custom IOleInPlaceActiveObject interface
   ' pointers.
   With m_IPAOHookStruct
      CopyMemory .IPAOReal, 0&, 4
      CopyMemory .TBEx, 0&, 4
   End With
   
   '
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "UseExplorerTheme", UseExplorerStyle, True
   PropBag.WriteProperty "UseExplorerTransitionStyle",
    UseExplorerTransitionStyle, True
   PropBag.WriteProperty "BackColorEnd", m_oBackColorEnd, vbWindowBackground
   PropBag.WriteProperty "BackColorStart", m_oBackColorStart, vbWindowBackground
   PropBag.WriteProperty "ShowFocusRect", m_bShowFocusRect, True
   PropBag.WriteProperty "Redraw", m_bRedraw, True
   '
End Sub