vbAccelerator - Contents of code file: vbalPicker.ctl

VERSION 5.00
Begin VB.UserControl vbalPicker 
   CanGetFocus     =   0   'False
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
End
Attribute VB_Name = "vbalPicker"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public Enum EVPLPickItemTypes
   evplIcon
   evplSeparator
   evplColour
   evplLineStyle
   evplLineWidth
   evplOwnerDraw
End Enum

Public Enum EVPLPickItemDropDrownStyle
   evplDropDown
   evplDropDownSplit
End Enum

Public Enum EVPLPickItemAlignment
   evplLeft
   evplCentre
   evplRight
End Enum

Public Enum EVPLDisplayStyle
   evplToolbar
   evplMenu
End Enum

Public Enum EVPLBorderStyleTypes
   evplNone
   evplFixedSingle
   evplThin
   evplRaised
End Enum

Public Enum EVPLHighlightStyleTypes
   evplThinBorders
   evplXp
   evplVSNET
End Enum

' Internal
Private m_colItems As Collection
Private WithEvents m_cMouseTrack As pcMouseTrack
Attribute m_cMouseTrack.VB_VarHelpID = -1
Private m_hWnd As Long
Private m_bRunTime As Boolean
Private m_bMouseDown As Boolean
Private m_lPtrMouseDownOn  As Long
Private m_bReCalc As Boolean
Private m_sLastItemKey As String
Private m_bInMenuLoop As Boolean
Private m_bShowTopLevelMenu As Boolean
Private m_hWndShownFrom As Long
Private m_bAltPressed As Boolean
Private m_tP As POINTAPI

' Redrawing:
Private m_bRedraw As Boolean
Private m_bDirty As Boolean
' Background:
Private m_bBitmap As Boolean
Private m_hDCSrc As Long
Private m_lBitmapW As Long
Private m_lBitmapH As Long
' Icons:
Private m_hIml As Long
Private m_ptrVb6ImageList As Long
Private m_lIconSizeX As Long
Private m_lIconSizeY As Long
' Enabled:
Private m_bEnabled As Boolean
' Size
Private m_fIdealHeight As Single
' Appearance
Private m_eBorderStyle As EVPLBorderStyleTypes
Private m_bScrollBar As Boolean
Private m_bIconBar As Boolean
Private m_bCheckBar As Boolean
Private m_eHighlightStyle As EVPLHighlightStyleTypes
Private m_eDisplayStyle As EVPLDisplayStyle
' General
Private m_sKey As String
Private m_sTag As String
Private m_lItemData As Long

Public Event ItemClick(Item As cPickItem)
Public Event InitPopup(Item As cPickItem)

Public Property Get Visible() As Boolean
   Visible = UserControl.Extender.Visible
End Property
Public Property Let Visible(ByVal bVisible As Boolean)
   UserControl.Extender.Visible = bVisible
End Property

Public Property Get DisplayStyle() As EVPLDisplayStyle
   DisplayStyle = m_eDisplayStyle
End Property
Public Property Let DisplayStyle(ByVal eStyle As EVPLDisplayStyle)
   m_eDisplayStyle = eStyle
End Property

Public Property Let ImageList( _
        ByRef vImageList As Variant _
    )
    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
                If (vImageList.ListImages.Count <>
                 ImageList_GetImageCount(m_hIml)) Then
                    Dim o As Object
                    Set o = vImageList
                    m_ptrVb6ImageList = ObjPtr(o)
                End If
            End If
        Else
            'pErr "Failed to Get Image list Handle"
        End If
        On Error GoTo 0
    End If
    If (m_hIml <> 0) Then
        If (m_ptrVb6ImageList <> 0) Then
            m_lIconSizeX = vImageList.ImageWidth
            m_lIconSizeY = vImageList.ImageHeight
        Else
            Dim rc As RECT
            ImageList_GetImageRect m_hIml, 0, rc
            m_lIconSizeX = rc.Right - rc.Left
            m_lIconSizeY = rc.Bottom - rc.Top
        End If
    End If
End Property


Public Property Get HighlightStyle() As EVPLHighlightStyleTypes
   HighlightStyle = m_eHighlightStyle
End Property
Public Property Let HighlightStyle(ByVal eHighlightStyle As
 EVPLHighlightStyleTypes)
   m_eHighlightStyle = eHighlightStyle
End Property

Public Property Get ScrollBar() As Boolean
   ScrollBar = m_bScrollBar
End Property
Public Property Let ScrollBar(ByVal bScrollBar As Boolean)
   m_bScrollBar = bScrollBar
End Property

Public Property Get IconBar() As Boolean
   IconBar = m_bIconBar
End Property
Public Property Let IconBar(ByVal bIconBar As Boolean)
   m_bIconBar = bIconBar
End Property

Public Property Get CheckBar() As Boolean
   CheckBar = m_bCheckBar
End Property
Public Property Let CheckBar(ByVal bCheckBar As Boolean)
   m_bCheckBar = bCheckBar
End Property

Public Sub SetWidth(ByVal lWidth As Single)
   UserControl.Width = lWidth
   UserControl.Height = m_fIdealHeight
End Sub

Public Property Get Enabled() As Boolean
   Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal bState As Boolean)
   m_bEnabled = bState
   UserControl.Enabled = bState
   UserControl.Cls
   UserControl.Refresh
   PropertyChanged "Enabled"
End Property
Public Property Set Font(iFnt As IFont)
   pSetFont iFnt
End Property
Public Property Let Font(iFnt As IFont)
   pSetFont iFnt
End Property
Public Property Get Font() As IFont
   Set Font = UserControl.Font
End Property
Public Property Get ForeColor() As OLE_COLOR
   ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal oColor As OLE_COLOR)
   UserControl.ForeColor = oColor
   PropertyChanged "ForeColor"
End Property
Public Property Get BackColor() As OLE_COLOR
   BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal oColor As OLE_COLOR)
   UserControl.BackColor = oColor
   PropertyChanged "BackColor"
End Property
Public Property Get BorderStyle() As EVPLBorderStyleTypes
   BorderStyle = m_eBorderStyle
End Property
Public Property Let BorderStyle(ByVal eStyle As EVPLBorderStyleTypes)
Dim lhWnd As Long
Dim lS As Long
   m_eBorderStyle = eStyle
   If (eStyle = evplThin) Or (eStyle = evplNone) Then
      UserControl.BorderStyle() = 0
   Else
      UserControl.BorderStyle() = Abs(eStyle = evplFixedSingle)
      lhWnd = UserControl.hWnd
      lS = GetWindowLong(lhWnd, GWL_EXSTYLE)
      If eStyle = evplFixedSingle Then
         lS = (lS Or WS_EX_CLIENTEDGE) And Not (WS_EX_STATICEDGE Or
          WS_EX_WINDOWEDGE)
      ElseIf eStyle = evplRaised Then
         lS = (lS Or WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE) And Not
          (WS_EX_STATICEDGE)
      Else
         lS = (lS Or WS_EX_STATICEDGE) And Not (WS_EX_CLIENTEDGE Or
          WS_EX_WINDOWEDGE)
      End If
      SetWindowLong lhWnd, GWL_EXSTYLE, lS
      
      SetWindowPos lhWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or
       SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED
   End If
   PropertyChanged "BorderStyle"
End Property
Public Property Get Redraw() As Boolean
   Redraw = m_bRedraw
End Property
Public Property Let Redraw(ByVal bState As Boolean)
   m_bRedraw = bState
   m_bReCalc = True
   UserControl.Cls
   UserControl.Refresh
   PropertyChanged "Redraw"
End Property
Public Property Get Key() As String
   Key = m_sKey
End Property
Public Property Let Key(ByVal sKey As String)
   m_sKey = sKey
End Property
Public Property Get hWnd() As Long
   hWnd = UserControl.hWnd
End Property
Public Property Get Items() As cPickItems
   Dim cI As New cPickItems
   cI.fInit m_hWnd
   Set Items = cI
End Property
Private Sub pSetFont(iFnt As IFont)
   If Not iFnt Is Nothing Then
      Set UserControl.Font = iFnt
      If m_bRedraw Then
         fRender
      End If
      PropertyChanged "Font"
   End If
End Sub
Private Sub pItemClick(cI As cPickItem, pc As pcItem)
   
   RaiseEvent ItemClick(cI)
      
   ' End of menu loop
   Debug.Print "ItemClick, EndMenuLoop"
   fEndMenuLoop
   
End Sub
Friend Sub fStartMenuLoop()
   
   If Not (m_bInMenuLoop) Then
      
      m_bInMenuLoop = True
      AttachMouseHook m_hWnd
   
   End If
   
End Sub

Friend Sub fEndMenuLoop()
   
   If m_bInMenuLoop Then
      Debug.Print "EndMenuLoop", m_sKey
      
      ' no need for mouse hooking
      DetachMouseHook m_hWnd
      
      If Not (m_hWndShownFrom = 0) Then
         Dim ctlPicker As vbalPicker
         Dim lErr As Long
         
         On Error Resume Next
         gbValidOwner m_hWndShownFrom, ctlPicker
         lErr = Err.Number
         On Error GoTo 0
         If (lErr = 0) Then
            ctlPicker.fEndMenuLoop
         End If
         
         m_hWndShownFrom = 0
         Dim vlPtr As Variant
         Dim pc As pcItem
         For Each vlPtr In m_colItems
            Set pc = ObjectFromPtr(vlPtr)
            pc.MouseOver = False
            pc.InMenuLoop = False
            pc.MouseDown = False
         Next
         ShowWindow m_hWnd, SW_HIDE
      Else
         Dim tP As POINTAPI
         Dim lhDC As Long
         lhDC = UserControl.hdc
         GetCursorPos tP
         ScreenToClient m_hWnd, tP
         For Each vlPtr In m_colItems
            Set pc = ObjectFromPtr(vlPtr)
            pc.InMenuLoop = False
            If fbHitTest(tP.x, tP.y, pc) Then
               pc.MouseDown = False
               If Not pc.MouseOver Then
                  pc.MouseOver = True
                  fEraseButton lhDC, pc
                  fDrawButton lhDC, pc
               End If
            ElseIf (pc.MouseOver) Or (pc.MouseDown) Then
               pc.MouseDown = False
               pc.MouseOver = False
               fEraseButton lhDC, pc
               fDrawButton lhDC, pc
            End If
         Next
      End If
   
      m_bAltPressed = False
      m_bInMenuLoop = False
   End If

End Sub

Private Function pMouseDownOn(pc As pcItem) As vbalPicker

   Dim cI As New cPickItem
   cI.fInit m_hWnd, ObjPtr(pc), pc.Key
      
   Dim ctlPicker As vbalPicker
   Dim vlPtr As Variant
   Dim pc0 As pcItem
   Dim lErr As Long
   Dim lhDC As Long
   
   ' Hide any existing drop downs:
   lhDC = UserControl.hdc
   For Each vlPtr In m_colItems
      Set pc0 = ObjectFromPtr(vlPtr)
      If Not pc0 Is pc Then
         lErr = 0
         On Error Resume Next
         gbValidOwner pc0.hWndDropDown, ctlPicker
         On Error GoTo 0
         If (lErr = 0) And Not (ctlPicker Is Nothing) Then
            ctlPicker.fHideOwnedPopups
            ctlPicker.fShownFrom = 0
            ShowWindow pc0.hWndDropDown, SW_HIDE
            pc0.MouseOver = False
            pc0.MouseDown = False
            pc0.InMenuLoop = False
            fEraseButton lhDC, pc0
            fDrawButton lhDC, pc0
         End If
      End If
   Next
   
   ' Do we have a drop down at the new item?
   Set ctlPicker = cI.DropDown
   
   If Not (ctlPicker Is Nothing) Then
      RaiseEvent InitPopup(cI)

      ' Show the drop-down object
      Dim lhWnd As Long
      lhWnd = ctlPicker.hWnd
      Dim lStyle As Long
      lStyle = GetWindowLong(lhWnd, GWL_EXSTYLE)
      lStyle = lStyle Or WS_EX_TOOLWINDOW
      lStyle = lStyle And Not (WS_EX_APPWINDOW)
      SetWindowLong lhWnd, GWL_EXSTYLE, lStyle
      Dim rc As RECT
      pc.GetRect rc
      Dim tP As POINTAPI
      If (m_eDisplayStyle = evplToolbar) Then
         tP.x = rc.Left
         tP.y = rc.Bottom
      Else
         tP.x = rc.Right
         tP.y = rc.Top
      End If
      ClientToScreen m_hWnd, tP
      SetParent lhWnd, HWND_DESKTOP
      GetWindowRect lhWnd, rc
      ' Show the form:
      SetWindowPos lhWnd, 0, tP.x, tP.y, rc.Right - rc.Left, rc.Bottom -
       rc.Top, SWP_SHOWWINDOW
      
      'Dim lT As Long
      'lT = GetWindowLong(lhWnd, GWL_EXSTYLE)
      'SetWindowLong lhWnd, GWL_EXSTYLE, lT Or WS_EX_LAYERED
      'SetLayeredWindowAttributes lhWnd, &H0, 240, LWA_ALPHA ' LWA_COLORKEY Or
      
      pc.InMenuLoop = True
      fStartMenuLoop
      ctlPicker.fShownFrom = m_hWnd
      ctlPicker.fStartMenuLoop
      Set pMouseDownOn = ctlPicker
            
   End If
   
End Function


Friend Property Let fShownFrom(ByVal lhWnd As Long)
   m_hWndShownFrom = lhWnd
End Property
Friend Property Get fShownFrom() As Long
   fShownFrom = m_hWndShownFrom
End Property

Friend Sub fClearBackground(lhDC As Long, tR As RECT)
Dim hBr As Long
   If (m_bBitmap) Then
      TileArea UserControl.hdc, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom
       - tR.Top, m_hDCSrc, m_lBitmapW, m_lBitmapH, 0, 0
   Else
      hBr = CreateSolidBrush(TranslateColor(UserControl.BackColor))
      FillRect UserControl.hdc, tR, hBr
      DeleteObject hBr
   End If
End Sub

Friend Sub fRender()
Dim tR As RECT
Dim lhDC As Long
   lhDC = UserControl.hdc
   GetClientRect m_hWnd, tR
   fClearBackground lhDC, tR
   fDrawButtons lhDC, tR
End Sub
Friend Sub fDrawButtons(ByVal lhDC As Long, tR As RECT)
Dim vlPtr As Variant
Dim pc As pcItem
   If Not m_colItems Is Nothing Then
      For Each vlPtr In m_colItems
         Set pc = ObjectFromPtr(vlPtr)
         fDrawButton lhDC, pc
      Next
   End If
End Sub
Friend Sub fEraseButton(ByVal lhDC As Long, pc As pcItem)
Dim tR As RECT
   pc.GetRect tR
   InflateRect tR, 0, 1
   fClearBackground lhDC, tR
End Sub
Friend Sub fUpdatedItem(pc As pcItem, Optional ByVal bMeasure As Boolean =
 False)
Dim lhDC As Long
   m_bReCalc = bMeasure
   If IsWindowVisible(m_hWnd) Then
      If bMeasure Then
         UserControl.Cls
         UserControl.Refresh
      Else
         lhDC = UserControl.hdc
         fEraseButton lhDC, pc
         fDrawButton lhDC, pc
      End If
   Else
      m_bReCalc = True
   End If
   fCalcPositions
End Sub
Friend Sub fDrawButton(ByVal lhDC As Long, ByRef pc As pcItem)
Dim tR As RECT
Dim tDR As RECT
Dim tTextR As RECT
Dim tIR As RECT
Dim tCR As RECT
Dim sCap As String
Dim bEnabled As Boolean
Dim hBr As Long
Dim lFmt As Long
Dim lOffset As Long
   
   bEnabled = (pc.Enabled And m_bEnabled)
   
   pc.GetRect tR
   LSet tDR = tR
   LSet tCR = tR
   If pc.Style = evplColour Then
      lOffset = Abs(pc.MouseDown And pc.MouseOver)
   Else
      If (m_bInMenuLoop) Then
         lOffset = Abs(pc.MouseDown)
      Else
         lOffset = Abs(pc.MouseDown And pc.MouseOver) + Abs(pc.Checked)
      End If
   End If
   OffsetRect tDR, lOffset, lOffset
      
   Select Case pc.Style
   Case evplSeparator
      ' Full line separator:
      tDR.Top = tDR.Top + 2
      DrawEdge lhDC, tDR, EDGE_ETCHED, BF_TOP
      
   Case evplIcon, evplColour
      
      If (pc.InMenuLoop Or pc.MouseOver Or pc.MouseDown) Then
         hBr = GetSysColorBrush(vbHighlight And &H1F&)
      Else
         hBr = GetSysColorBrush(vbWindowBackground And &H1F&)
      End If
      FillRect lhDC, tCR, hBr
      DeleteObject hBr
      
      sCap = pc.Caption
      LSet tIR = tCR
      InflateRect tIR, -1, -1
      If Len(sCap) > 0 Then
         tIR.Right = tIR.Left + m_lIconSizeX
      End If
      If pc.Checked And Not pc.MouseOver Then
         ' Fill check background
         hBr = LighterBrush(UserControl.BackColor)
         If pc.Style = evplColour Then
            FillRect lhDC, tCR, hBr
         Else
            If Len(sCap) > 0 Then
               If pc.Icon > -1 Then
                  ' Just fill the icon:
                  FillRect lhDC, tIR, hBr
               Else
                  ' Fill the entire:
                  FillRect lhDC, tR, hBr
               End If
            End If
         End If
         DeleteObject hBr
      End If
      LSet tIR = tDR
      InflateRect tIR, -3, -3
      
      If pc.Style = evplColour Then
         If bEnabled Then
            DrawRect lhDC, tIR, vbButtonShadow
            InflateRect tIR, -1, -1
            hBr = CreateSolidBrush(TranslateColor(pc.Colour))
            FillRect lhDC, tIR, hBr
            DeleteObject hBr
         Else
            OffsetRect tIR, -1, -1
            DrawRect lhDC, tIR, vb3DHighlight
            OffsetRect tIR, 1, 1
            DrawRect lhDC, tR, vbButtonShadow
         End If
      Else
         If pc.Icon > -1 Then
            DrawImage m_hIml, pc.Icon, lhDC, tIR.Left, tIR.Top, m_lIconSizeX,
             m_lIconSizeY, , , Not (bEnabled)
            tDR.Left = tDR.Left + m_lIconSizeX + 10
         Else
            tDR.Left = tDR.Left + 6
         End If
      End If
      
      If Len(sCap) > 0 Then
         LSet tTextR = tDR
         tTextR.Right = tTextR.Right - 4
         tTextR.Top = tTextR.Top + 1
         tTextR.Bottom = tTextR.Bottom - 1
         lFmt = DT_SINGLELINE Or DT_VCENTER Or DT_WORD_ELLIPSIS
         If Not (m_bAltPressed) Then
            sCap = Replace(sCap, "&", "")
            lFmt = lFmt Or DT_NOPREFIX
         End If
         If pc.Alignment = evplRight Then
            lFmt = lFmt Or DT_RIGHT
         ElseIf pc.Alignment = evplCentre Then
            lFmt = lFmt Or DT_CENTER
         End If
         If Not bEnabled Then
            OffsetRect tTextR, 1, 1
            SetTextColor lhDC, TranslateColor(vb3DHighlight)
            DrawText lhDC, sCap, -1, tTextR, lFmt
            OffsetRect tTextR, -1, -1
            SetTextColor lhDC, TranslateColor(vbButtonShadow)
         Else
            SetTextColor lhDC, TranslateColor(ForeColor)
         End If
         DrawText lhDC, sCap, -1, tTextR, lFmt
      End If
      
      InflateRect tR, 0, 1
      If pc.MouseDown Then
         If pc.MouseOver Then
            DrawEdge lhDC, tR, BDR_SUNKENOUTER, BF_RECT
         Else
            DrawEdge lhDC, tR, BDR_RAISEDINNER, BF_RECT
         End If
      ElseIf pc.Checked Then
         DrawEdge lhDC, tR, BDR_SUNKENOUTER, BF_RECT
      ElseIf pc.MouseOver Then
         DrawEdge lhDC, tR, BDR_RAISEDINNER, BF_RECT
      End If
   
   Case evplLineStyle
   
   Case evplLineWidth
   
   Case evplOwnerDraw
   
   End Select
   
End Sub
Friend Sub fCalcPositions()
Dim vlPtr As Variant
Dim pc As pcItem
Dim lX As Long
Dim lY As Long
Dim lW As Long
Dim tR As RECT
Dim tIR As RECT
Dim lH As Long
Dim bNewLine As Long
   
   If Not m_colItems Is Nothing Then
      GetClientRect m_hWnd, tR
      
      For Each vlPtr In m_colItems
         Set pc = ObjectFromPtr(vlPtr)
         
         If Len(pc.Caption) > 0 Then
            
            lY = lY + lH + 1
            lH = m_lIconSizeY + 6
            lX = 0
            lW = tR.Right - tR.Left
            bNewLine = True
            
         ElseIf pc.Style = evplSeparator Then
            lY = lY + lH + 1
            lH = 6
            lX = 0
            lW = tR.Right - tR.Left
            bNewLine = True
         
         ElseIf pc.Style = evplLineWidth Then
            lY = lY + lH + 1
            lH = 6 + pc.LineWidth
            lX = 0
            lW = tR.Right - tR.Left
            bNewLine = True
            
         ElseIf pc.Style = evplLineStyle Then
            lY = lY + lH + 1
            lH = 6 + pc.LineWidth
            lX = 0
            lW = tR.Right - tR.Left
            bNewLine = True
            
         ElseIf pc.Style = evplOwnerDraw Then
            ' TODO
            
         Else
            If bNewLine = True Or _
               (((lX + 2 * (m_lIconSizeX + 6)) >= (tR.Right - tR.Left)) And (lX
                > 0)) Then
               lX = 0
               lY = lY + lH + 1
               lH = m_lIconSizeY + 6
               lW = m_lIconSizeX + 6
            Else
               lX = lX + m_lIconSizeX + 6 + 1
               If lH < m_lIconSizeY + 6 Then
                  lH = m_lIconSizeY + 6
               End If
               lW = m_lIconSizeX + 6
            End If
            bNewLine = False
            
         End If
         
         tIR.Top = lY
         tIR.Bottom = lY + lH
         tIR.Left = lX
         tIR.Right = lX + lW
         pc.SetRect tIR
         
         m_fIdealHeight = (tIR.Bottom + 3) * Screen.TwipsPerPixelY
      Next
   End If
   
End Sub
Friend Sub fClear()

   If Not m_colItems Is Nothing Then
      ' Ensure we clear up any objects we
      ' created:
      Dim vlPtr As Variant
      Dim cItem As pcItem
      For Each vlPtr In m_colItems
         Set cItem = ObjectFromPtr(vlPtr)
         IRelease cItem
      Next
   
      ' recreate a blank object collection
      Set m_colItems = Nothing
      Set m_colItems = New Collection
   End If
   
End Sub

Friend Function fGetItem(Index As Variant, lPtr As Long, cI As pcItem) As
 Boolean
   lPtr = 0: Set cI = Nothing
   On Error Resume Next
   lPtr = m_colItems(Index)
   If Err.Number = 0 Then
      If Not (lPtr = 0) Then
         Set cI = ObjectFromPtr(lPtr)
         fGetItem = True
      Else
         ' not found
         gErr 6
      End If
   Else
      ' Not found:
      gErr 6
   End If
End Function
Friend Function fCheckNewKey(Key As Variant) As Boolean
Dim l As Long
   If IsNumeric(Key) Then
      gErr 4
   Else
      On Error Resume Next
      l = m_colItems(Key)
      If Err.Number = 0 Then
         gErr 5
      Else
         fCheckNewKey = True
      End If
   End If
End Function
Friend Function fAddItem( _
      ByVal sKeyBefore As String, _
      ByVal sKey As String, _
      ByVal lID As Long, _
      ByVal eStyle As EVPLPickItemTypes, _
      ByVal sCaption As String, _
      ByVal iIcon As Long, _
      ByRef cR As cPickItem _
   ) As Long
Dim lPtr As Long
Dim pc As pcItem

   Set pc = New pcItem
   With pc
      .ID = lID
      .Style = eStyle
      .Caption = sCaption
      .Icon = iIcon
      .Key = sKey
   End With
   
   lPtr = ObjPtr(pc)
   
   On Error Resume Next
   If Len(sKeyBefore) = 0 Then
      m_colItems.Add lPtr, sKey
   Else
      m_colItems.Add lPtr, sKey, sKeyBefore
   End If
   On Error GoTo 0
   If Err.Number = 0 Then
      ' Make sure pc keeps alive
      IAddRef pc
      ' Return the cPickItem object:
      cR.fInit m_hWnd, lPtr, sKey
      fAddItem = lPtr
   Else
      ' Probably out of memory..
      gErr 7
   End If
   fCalcPositions
   
End Function

Friend Function fIsValid(ByVal sKey As String, ByVal lPtr As Long) As Boolean
   On Error Resume Next
   fIsValid = (m_colItems(sKey) = lPtr)
   If Err.Number = 0 Then
      On Error GoTo 0
      fIsValid = True
   Else
      On Error GoTo 0
      gErr 6
   End If
End Function

Friend Sub fRemoveItem(Index As Variant)
Dim lPtr As Long
Dim pc As pcItem
   On Error Resume Next
   lPtr = m_colItems.Item(Index)
   If Err.Number = 0 Then
      On Error GoTo 0
      Set pc = ObjectFromPtr(lPtr)
      IRelease pc
      m_colItems.Remove Index
   End If
   fCalcPositions
End Sub
Friend Property Get fItemCount() As Long
   fItemCount = m_colItems.Count
End Property

Private Sub m_cMouseTrack_MouseHover(Button As MouseButtonConstants, Shift As
 ShiftConstants, x As Single, y As Single)
   m_cMouseTrack.StartMouseTracking
End Sub

Private Sub m_cMouseTrack_MouseLeave()
   UserControl_MouseMove 0, 0, -15 * Screen.TwipsPerPixelX, -15 *
    Screen.TwipsPerPixelY
End Sub

Friend Function fbHitTest(ByVal x As Long, ByVal y As Long, ByRef pc As pcItem)
 As Boolean
Dim vlPtr As Variant
Dim pcE As pcItem
Dim tIR As RECT
   For Each vlPtr In m_colItems
      Set pcE = ObjectFromPtr(vlPtr)
      pcE.GetRect tIR
      If PtInRect(tIR, x, y) Then
         Set pc = pcE
         fbHitTest = True
      End If
   Next

End Function

Friend Sub fHideOwningPopups()
Dim lErr As Long
   
   lErr = 0
   Dim ctlPicker As vbalPicker
   On Error Resume Next
   gbValidOwner m_hWndShownFrom, ctlPicker
   lErr = Err.Number
   On Error GoTo 0
   If (lErr = 0) And Not (ctlPicker Is Nothing) Then
      ctlPicker.fHideOwningPopups
      ShowWindow m_hWnd, SW_HIDE
      m_hWndShownFrom = 0
   End If
   
   Dim vlPtr As Variant
   Dim pc As pcItem
   For Each vlPtr In m_colItems
      Set pc = ObjectFromPtr(vlPtr)
      pc.MouseOver = False
      pc.MouseDown = False
      pc.InMenuLoop = False
   Next
End Sub

Friend Sub fHideOwnedPopups(Optional ByVal bHiding As Boolean = False)
   
   Dim vlPtr As Variant
   Dim pc As pcItem
   Dim lErr As Long
   
   For Each vlPtr In m_colItems
      Set pc = ObjectFromPtr(vlPtr)
      If Not (pc.hWndDropDown = 0) Then
         lErr = 0
         Dim ctlPicker As vbalPicker
         On Error Resume Next
         gbValidOwner pc.hWndDropDown, ctlPicker
         lErr = Err.Number
         On Error GoTo 0
         If (lErr = 0) And Not (ctlPicker Is Nothing) Then
            ctlPicker.fHideOwnedPopups True
            ctlPicker.fShownFrom = 0
            ShowWindow pc.hWndDropDown, SW_HIDE
         End If
      End If
      If bHiding Then
         pc.MouseOver = False
      End If
      pc.MouseDown = False
      pc.InMenuLoop = False
   Next
      
End Sub

Private Function pNextSelectableItem(ByVal iIndex As Long, ByVal iDirection As
 Long) As Long
Dim bComplete As Boolean
Dim iNextIndex As Long
Dim lPtr As Long
Dim pc As pcItem
   
   iNextIndex = iIndex
   Do While Not bComplete
      iNextIndex = iNextIndex + iDirection
      If (iNextIndex > m_colItems.Count) Then
         iNextIndex = 1
      End If
      If (iNextIndex < 1) Then
         iNextIndex = m_colItems.Count
      End If
      If (iNextIndex = iIndex) Then
         bComplete = True
      Else
         On Error Resume Next
         fGetItem iNextIndex, lPtr, pc
         If Not (pc.Style = evplSeparator) Then
            bComplete = True
         End If
      End If
   Loop
   pNextSelectableItem = iNextIndex
   
End Function

Friend Function fMousePress(ByVal x As Long, ByVal y As Long) As Boolean
Dim tP As POINTAPI
Dim tR As RECT
Dim bRet As Boolean
      
   If IsWindowVisible(m_hWnd) Then
      bRet = True
      tP.x = x
      tP.y = y
      ScreenToClient m_hWnd, tP
      GetClientRect m_hWnd, tR
      If (PtInRect(tR, tP.x, tP.y) = 0) Then
         bRet = False
      End If
   End If
   fMousePress = bRet
   
End Function

Private Function pMatchAccelerator(ByVal Key As Long, ByVal sCaption As String)
 As Boolean
Dim iPos As Long
Dim sC As String
   iPos = InStr(sCaption, "&")
   If (iPos > 0) And (iPos < Len(sCaption)) Then
      sC = Mid(sCaption, iPos + 1, 1)
      If (sC = Chr(Key)) Then
         pMatchAccelerator = True
      End If
   End If
End Function

Friend Function fInMenuLoop() As Boolean
   fInMenuLoop = m_bInMenuLoop
End Function

Friend Sub fSetMousePos()
   GetCursorPos m_tP
End Sub

Friend Function fKeyPress(ByVal Key As Long, ByVal Mask As ShiftConstants,
 ByVal KeyUp As Boolean) As Boolean
         
   ' Accelerator check first:
      
   
   ' Processing on window:
   If IsWindowVisible(m_hWnd) Then
   
      Dim i As Long
      
      ' Alt processing:
      If (Mask And vbAltMask) = vbAltMask Then
         If (KeyUp) Then
            m_bAltPressed = False
            fKeyPress = True
         Else
            If Not m_bAltPressed Then
               Debug.Print "NewAlt Press, EndMenuLoop"
               fEndMenuLoop
               m_bAltPressed = True
               If (m_hWndShownFrom = 0) Then
                  ' highlight the first item:
                  fButtonHighlighted(1) = True
                  fStartMenuLoop
                  fKeyPress = True
               End If
            End If
         End If
      Else
         
      End If
      
      If m_bInMenuLoop Then
         If Not (KeyUp) Then
            
            Debug.Print "InMenuLoop, KeyPress"
            
            ' Am I the deepest shown menu level?
            Dim vlPtr As Variant
            Dim pc As pcItem
            Dim bShowingMenu As Boolean
            Dim iSelIndex As Long
            Dim iAccelIndex As Long
            Dim pcSel As pcItem
            Dim pcNew As pcItem
            Dim pcAccel As pcItem
            Dim ctlPicker As vbalPicker
            Dim lErr As Long
            
            For Each vlPtr In m_colItems
               i = i + 1
               Set pc = ObjectFromPtr(vlPtr)
               If (pc.InMenuLoop) Then
                  ' not me
                  Debug.Print pc.Key; " is showing menu"
                  bShowingMenu = True
                  Exit For
               ElseIf (pc.MouseOver) Then
                  Set pcSel = pc
                  iSelIndex = i
               End If
               If (iAccelIndex = 0) Then
                  If pMatchAccelerator(Key, pc.Caption) Then
                     Set pcAccel = pc
                     iAccelIndex = i
                  End If
               End If
            Next
                  
            If Not bShowingMenu Then
               Debug.Print "Not Showing a Menu"
               
               Select Case Key
               Case vbKeyUp
                  
                  If Not (m_hWndShownFrom = 0) Then
                     iSelIndex = pNextSelectableItem(iSelIndex, -1)
                  
                     If Not pcSel Is Nothing Then
                        pcSel.MouseOver = False
                        fEraseButton UserControl.hdc, pcSel
                        fDrawButton UserControl.hdc, pcSel
                     End If
                  
                     Set pcNew = ObjectFromPtr(m_colItems(iSelIndex))
                     pcNew.MouseOver = True
                     fEraseButton UserControl.hdc, pcNew
                     fDrawButton UserControl.hdc, pcNew
                     fKeyPress = True
                  Else
                     ' up or down show the drop down menu:
                     If Not pcSel Is Nothing Then
                        If Not (pcSel.hWndDropDown = 0) Then
                           On Error Resume Next
                           gbValidOwner pcSel.hWndDropDown, ctlPicker
                           lErr = Err.Number
                           On Error GoTo 0
                           If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                              ' show popup
                              ctlPicker.fSetMousePos
                              Set ctlPicker = pMouseDownOn(pcSel)
                              ctlPicker.fButtonHighlighted(1) = True
                              fButtonHighlighted(iSelIndex) = True
                              If (m_hWndShownFrom = 0) Then
                                 m_bShowTopLevelMenu = True
                              End If
                              fKeyPress = True
                           End If
                        End If
                     End If
                     
                  End If
                  
               Case vbKeyDown
                  If Not (m_hWndShownFrom = 0) Then
                     iSelIndex = pNextSelectableItem(iSelIndex, 1)
                  
                     If Not pcSel Is Nothing Then
                        pcSel.MouseOver = False
                        fEraseButton UserControl.hdc, pcSel
                        fDrawButton UserControl.hdc, pcSel
                     End If
                  
                     Set pcNew = ObjectFromPtr(m_colItems(iSelIndex))
                     pcNew.MouseOver = True
                     fEraseButton UserControl.hdc, pcNew
                     fDrawButton UserControl.hdc, pcNew
                     fKeyPress = True
                  Else
                     ' up or down show the drop down menu:
                     If Not pcSel Is Nothing Then
                        If Not (pcSel.hWndDropDown = 0) Then
                           On Error Resume Next
                           gbValidOwner pcSel.hWndDropDown, ctlPicker
                           lErr = Err.Number
                           On Error GoTo 0
                           If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                              ' show popup
                              ctlPicker.fSetMousePos
                              Set ctlPicker = pMouseDownOn(pcSel)
                              ctlPicker.fButtonHighlighted(1) = True
                              fButtonHighlighted(iSelIndex) = True
                              If (m_hWndShownFrom = 0) Then
                                 m_bShowTopLevelMenu = True
                              End If
                              fKeyPress = True
                           End If
                        End If
                     End If
                     
                  End If
               
               Case vbKeyEscape
                  If Not (m_hWndShownFrom = 0) Then
                     ' hide me
                     On Error Resume Next
                     gbValidOwner m_hWndShownFrom, ctlPicker
                     lErr = Err.Number
                     On Error GoTo 0
                     If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                        ctlPicker.fHideOwnedPopups
                        fKeyPress = True
                     End If
                  Else
                     m_bShowTopLevelMenu = False
                  End If
                  
               Case vbKeyLeft
                  If Not (m_hWndShownFrom = 0) Then
                     ' hide me
                     On Error Resume Next
                     gbValidOwner m_hWndShownFrom, ctlPicker
                     lErr = Err.Number
                     On Error GoTo 0
                     If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                        ' hide me:
                        ctlPicker.fHideOwnedPopups
                        If (ctlPicker.fShownFrom = 0) Then
                           ' Now move to the prior item &
                           ' display if possible
                           fKeyPress = ctlPicker.fKeyPress(vbKeyLeft, Mask,
                            KeyUp)
                        Else
                           fKeyPress = True
                        End If
                     End If
                     
                  Else
                     ' left moves to the prior menu and then attempts
                     ' to display it:
                     
                     ' Prior menu:
                     iSelIndex = pNextSelectableItem(iSelIndex, -1)
                  
                     If Not pcSel Is Nothing Then
                        pcSel.MouseOver = False
                        fEraseButton UserControl.hdc, pcSel
                        fDrawButton UserControl.hdc, pcSel
                     End If
                  
                     Set pcNew = ObjectFromPtr(m_colItems(iSelIndex))
                     pcNew.MouseOver = True
                     fEraseButton UserControl.hdc, pcNew
                     fDrawButton UserControl.hdc, pcNew
                     
                     ' Show drop down if any:
                     If (m_bShowTopLevelMenu) Then
                        fKeyPress = fKeyPress(vbKeyDown, Mask, KeyUp)
                     End If
                     
                  End If
                           
               Case vbKeyRight
                  If Not pcSel Is Nothing Then
                     If (m_hWndShownFrom = 0) Then
                        ' next item along:
                        iSelIndex = pNextSelectableItem(iSelIndex, 1)
                     
                        If Not pcSel Is Nothing Then
                           pcSel.MouseOver = False
                           fEraseButton UserControl.hdc, pcSel
                           fDrawButton UserControl.hdc, pcSel
                        End If
                     
                        Set pcNew = ObjectFromPtr(m_colItems(iSelIndex))
                        pcNew.MouseOver = True
                        fEraseButton UserControl.hdc, pcNew
                        fDrawButton UserControl.hdc, pcNew
                        
                        ' Show drop down if any:
                        If Not (pcNew.hWndDropDown = 0) Then
                           If (m_bShowTopLevelMenu) Then
                              fKeyPress = fKeyPress(vbKeyDown, Mask, KeyUp)
                           End If
                        Else
                           fKeyPress = True
                        End If
                     Else
                        If Not (pcSel.hWndDropDown = 0) Then
                           On Error Resume Next
                           gbValidOwner pcSel.hWndDropDown, ctlPicker
                           lErr = Err.Number
                           On Error GoTo 0
                           If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                              ' show popup
                              ctlPicker.fSetMousePos
                              Set ctlPicker = pMouseDownOn(pcSel)
                              ctlPicker.fButtonHighlighted(1) = True
                              fButtonHighlighted(iSelIndex) = True
                              fKeyPress = True
                           End If
                        Else
                           Dim ctlParent As vbalPicker
                           Set ctlParent = Me
                           Do
                              lErr = 0
                              On Error Resume Next
                              gbValidOwner ctlParent.fShownFrom, ctlPicker
                              lErr = Err.Number
                              On Error GoTo 0
                              If (lErr = 0) Then
                                 If Not ctlPicker Is Nothing Then
                                    Set ctlParent = ctlPicker
                                 Else
                                    lErr = 5
                                 End If
                              End If
                           Loop While (lErr = 0) And Not (ctlPicker Is Nothing)
                           If Not ctlParent Is Nothing Then
                              ctlParent.fHideOwnedPopups
                              fKeyPress = ctlParent.fKeyPress(vbKeyRight, Mask,
                               KeyUp)
                           End If
                              
                        End If
                     End If
                  End If
                 
               Case vbKeyReturn
                  If Not pcSel Is Nothing Then
                     If Not (pcSel.hWndDropDown = 0) Then
                        fKeyPress = fKeyPress(vbKeyRight, Mask, KeyUp)
                     Else
                        ' click an item
                        Dim cI As New cPickItem
                        cI.fInit m_hWnd, ObjPtr(pcSel), pcSel.Key
                        pItemClick cI, pcSel
                        fKeyPress = True
                     End If
                  End If
               
               Case Else
                  ' match up accelerator; if found then press
                  If Not pcAccel Is Nothing Then
                     If Not (pcAccel.hWndDropDown = 0) Then
                        If Not pcSel Is Nothing Then
                           pcSel.MouseOver = False
                        End If
                        pcAccel.MouseOver = True
                        fButtonHighlighted(iAccelIndex) = True
                        If (m_hWndShownFrom = 0) Then
                           ' show the drop down:
                           On Error Resume Next
                           gbValidOwner pcAccel.hWndDropDown, ctlPicker
                           lErr = Err.Number
                           On Error GoTo 0
                           If (lErr = 0) And Not (ctlPicker Is Nothing) Then
                              ' show popup
                              ctlPicker.fSetMousePos
                              Set ctlPicker = pMouseDownOn(pcAccel)
                              ctlPicker.fButtonHighlighted(1) = True
                              fButtonHighlighted(iSelIndex) = True
                           End If
                           fKeyPress = True
                        Else
                           fKeyPress = fKeyPress(vbKeyRight, Mask, KeyUp)
                        End If
                     Else
                        cI.fInit m_hWnd, ObjPtr(pcAccel), pcAccel.Key
                        pItemClick cI, pcAccel
                        fKeyPress = True
                     End If
                  End If
               End Select
            End If
            
         End If
         
      End If
   End If
   
End Function

Friend Property Get fButtonHighlighted(ByVal vKey As Variant) As Boolean
Dim lPtr As Long
Dim pc As pcItem
Dim lErr As Long
   On Error Resume Next
   fGetItem vKey, lPtr, pc
   lErr = Err.Number
   On Error GoTo 0
   If (lErr = 0) And Not (pc Is Nothing) Then
      fButtonHighlighted = pc.MouseOver
   End If
End Property
Friend Property Let fButtonHighlighted(ByVal vKey As Variant, ByVal bState As
 Boolean)

Dim bOk As Boolean
Dim lPtr As Long
Dim pc As pcItem
Dim pc0 As pcItem
Dim vlPtr As Variant
Dim lhDC As Long

   On Error Resume Next
   bOk = fGetItem(vKey, lPtr, pc)
   On Error GoTo 0
   If (bOk) Then
      lhDC = UserControl.hdc
      If (bState) Then
         Dim i As Long
         For Each vlPtr In m_colItems
            i = i + 1
            Set pc0 = ObjectFromPtr(vlPtr)
            If (pc0 Is pc) Then
               pc0.MouseOver = True
               fEraseButton lhDC, pc0
               fDrawButton lhDC, pc0
            Else
               If (pc0.MouseOver) Then
                  pc0.MouseOver = False
                  fEraseButton lhDC, pc0
                  fDrawButton lhDC, pc0
               End If
            End If
         Next
      Else
         pc.MouseOver = False
         fEraseButton lhDC, pc
         fDrawButton lhDC, pc
      End If
   End If
End Property

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

Private Sub pInitialise()
   If UserControl.Ambient.UserMode Then
      m_bRunTime = True
      m_hWnd = UserControl.hWnd
      gInitialise m_hWnd, Me
      Set m_colItems = New Collection
      Set m_cMouseTrack = New pcMouseTrack
      m_cMouseTrack.AttachMouseTracking Me
      AttachKeyboardHook m_hWnd
   Else
      m_bRunTime = False
   End If
End Sub

Private Sub UserControl_Initialize()
   m_bRedraw = True
   m_bEnabled = True
   m_lIconSizeX = 16
   m_lIconSizeY = 16
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

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

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   '
End Sub

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

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
Dim tP As POINTAPI
Dim pc As pcItem
Dim lhDC As Long
   '
   If Button = vbLeftButton Then
      m_bMouseDown = True
      tP.x = x \ Screen.TwipsPerPixelX
      tP.y = y \ Screen.TwipsPerPixelY
      If fbHitTest(tP.x, tP.y, pc) Then
         If pc.Enabled Then
            If (pc.InMenuLoop) Then
               If (m_hWndShownFrom = 0) Then
                  fEndMenuLoop
               End If
            Else
               m_lPtrMouseDownOn = ObjPtr(pc)
               pc.MouseDown = True
               pc.MouseOver = True
               lhDC = UserControl.hdc
               fEraseButton lhDC, pc
               fDrawButton lhDC, pc
               If Not (pMouseDownOn(pc) Is Nothing) Then
               End If
            End If
         End If
      End If
   End If
   
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)
Dim tP As POINTAPI
Dim tR As RECT, tIR As RECT
Dim vlPtr As Variant
Dim pc As pcItem
Dim pcO As pcItem
Dim bIn As Boolean
Dim lhDC As Long
      
   GetCursorPos tP
   If (m_tP.x = tP.x) And (m_tP.y = tP.y) Then
      Exit Sub
   Else
      LSet m_tP = tP
   End If

   lhDC = UserControl.hdc
   GetClientRect m_hWnd, tR
   tP.x = x \ Screen.TwipsPerPixelX
   tP.y = y \ Screen.TwipsPerPixelY
   bIn = Not (PtInRect(tR, tP.x, tP.y) = 0)
   If bIn Then
      If Not m_cMouseTrack.Tracking Then
         m_cMouseTrack.StartMouseTracking
      End If
   End If
   
   If m_lPtrMouseDownOn > 0 Then
      Set pc = ObjectFromPtr(m_lPtrMouseDownOn)
      pc.GetRect tIR
      If PtInRect(tIR, tP.x, tP.y) Then
         If Not pc.MouseOver Then
            pc.MouseOver = True
            fEraseButton lhDC, pc
            fDrawButton lhDC, pc
         End If
      Else
         If pc.MouseOver Then
            pc.MouseOver = False
            fEraseButton lhDC, pc
            fDrawButton lhDC, pc
         End If
      End If
   Else
      For Each vlPtr In m_colItems
         Set pc = ObjectFromPtr(vlPtr)
         If bIn Then
            pc.GetRect tIR
            If PtInRect(tIR, tP.x, tP.y) Then
               Set pcO = pc
            Else
               If pc.MouseOver Then
                  pc.MouseOver = False
                  If (pc.InMenuLoop) Then
                     fHideOwnedPopups
                  End If
                  fEraseButton lhDC, pc
                  fDrawButton lhDC, pc
               End If
            End If
         Else
            If pc.MouseOver Then
               pc.MouseOver = False
               fEraseButton lhDC, pc
               fDrawButton lhDC, pc
            End If
         End If
      Next
      If Not pcO Is Nothing Then
         If Not pcO.MouseOver Then
            pcO.MouseOver = True
            If m_bInMenuLoop Or Not (m_hWndShownFrom = 0) Then
               m_bShowTopLevelMenu = True
               pMouseDownOn pcO
            End If
            fEraseButton lhDC, pcO
            fDrawButton lhDC, pcO
         End If
      End If
   End If
   
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As
 Single, y As Single)
Dim tP As POINTAPI
Dim lhDC As Long
Dim pcE As pcItem
Dim pc As pcItem
Dim bOver As Boolean
   '
   If m_bMouseDown Then
      If Not (m_lPtrMouseDownOn = 0) Then
      
         Set pcE = ObjectFromPtr(m_lPtrMouseDownOn)
         tP.x = x \ Screen.TwipsPerPixelX
         tP.y = y \ Screen.TwipsPerPixelY
         If fbHitTest(tP.x, tP.y, pc) Then
            If pc.Key = pcE.Key Then
               ' Hit!
               Dim cI As New cPickItem
               cI.fInit m_hWnd, ObjPtr(pc), pc.Key
               If (pc.hWndDropDown = 0) Then
                  pItemClick cI, pc
               End If
            End If
         End If
         pcE.MouseDown = False
         ' If the user has shown another form or msgbox or something,
         ' then we need to recomfirm whether it should be displayed or
         ' not:
         GetCursorPos tP
         ScreenToClient m_hWnd, tP
         If fbHitTest(tP.x, tP.y, pc) Then
            If pc.Key = pcE.Key Then
               bOver = True
            End If
         End If
         If Not bOver Then
            pcE.MouseOver = False
         End If
         ' Redraw button in appropriate state:
         lhDC = UserControl.hdc
         fEraseButton lhDC, pcE
         fDrawButton lhDC, pcE
      End If
   End If
   m_bMouseDown = False
   m_lPtrMouseDownOn = 0
End Sub

Private Sub UserControl_Paint()
   If m_bReCalc Then
      fCalcPositions
      m_bReCalc = False
   End If
   fRender
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   Redraw = PropBag.ReadProperty("Redraw", True)
   Enabled = PropBag.ReadProperty("Enabled", True)
   Picture = PropBag.ReadProperty("Picture", Nothing)
   BackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
   ForeColor = PropBag.ReadProperty("ForeColor", vbWindowText)
   Font = PropBag.ReadProperty("Font", Nothing)
   BorderStyle = PropBag.ReadProperty("BorderStyle", evplNone)
   '
   pInitialise
   '
End Sub

Private Sub UserControl_Resize()
   '
   If m_bRedraw Then
      fCalcPositions
      fRender
   End If
   '
End Sub

Private Sub UserControl_Terminate()
   ' Make sure we clear up
   Set m_cMouseTrack = Nothing
   DetachKeyboardHook m_hWnd
   DetachMouseHook m_hWnd
   fClear
   gTerminate m_hWnd
   '
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "Redraw", Redraw, True
   PropBag.WriteProperty "Enabled", Enabled, True
   PropBag.WriteProperty "BackColor", BackColor, vbButtonFace
   PropBag.WriteProperty "ForeColor", ForeColor, vbWindowText
   PropBag.WriteProperty "Picture", Picture, Nothing
   PropBag.WriteProperty "Font", Font, Nothing
   PropBag.WriteProperty "BorderStyle", BorderStyle, evplNone
   '
End Sub