vbAccelerator - Contents of code file: ddnMultiSelect.ctl

VERSION 5.00
Begin VB.UserControl ddnMultiSelect 
   AutoRedraw      =   -1  'True
   ClientHeight    =   2145
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3300
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   143
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   220
   ToolboxBitmap   =   "ddnMultiSelect.ctx":0000
   Begin VB.Timer tmrLostMouse 
      Enabled         =   0   'False
      Interval        =   50
      Left            =   2160
      Top             =   960
   End
End
Attribute VB_Name = "ddnMultiSelect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const MAGIC_END_EDIT_IGNORE_WINDOW_PROP As String = "VBAL:SGRID:EDITOR"

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Declare Function OpenThemeData Lib "uxtheme.dll" _
   (ByVal hWnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
   (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal lhDC As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    pRect As RECT, pClipRect As RECT) As Long
    
Private Declare 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 ScreenToClient Lib "user32" (ByVal hWnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function ImageList_GetImageRect Lib "comctl32.dll" ( _
        ByVal hIml As Long, _
        ByVal i As Long, _
        prcImage As RECT _
    ) As Long
Private Declare Function ImageList_Draw Lib "comctl32.dll" ( _
        ByVal hIml As Long, ByVal i As Long, _
        ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, _
        ByVal fStyle As Long _
    ) As Long
Private 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&

Private Declare Function CreateSolidBrush Lib "gdi32" (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 InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
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 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 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR
 As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2

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 PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
 Long, ByVal ptY As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hWnd As Long, ByVal nIndex As Long) As Long
   Private Const GWL_STYLE = (-16)
   Private Const WS_BORDER = &H800000
   Private Const WS_CHILD = &H40000000
   Private Const WS_DISABLED = &H8000000
   Private Const WS_VISIBLE = &H10000000
   Private Const WS_TABSTOP = &H100000
   Private Const WS_HSCROLL = &H100000
   Private Const GWL_EXSTYLE = (-20)
   Private Const WS_EX_TOPMOST = &H8&
   Private Const WS_EX_CLIENTEDGE = &H200&
   Private Const WS_EX_STATICEDGE = &H20000
   Private Const WS_EX_WINDOWEDGE = &H100&
   Private Const WS_EX_APPWINDOW = &H40000
   Private Const WS_EX_TOOLWINDOW = &H80&
   Private Const WS_EX_LAYERED As Long = &H80000

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal
 nCmdShow As Long) As Long
   Private Const SW_HIDE = 0

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
   Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send
    WM_NCCALCSIZE
   Private Const SWP_NOACTIVATE = &H10
   Private Const SWP_NOMOVE = &H2
   Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering
   Private Const SWP_NOREDRAW = &H8
   Private Const SWP_NOSIZE = &H1
   Private Const SWP_NOZORDER = &H4
   Private Const SWP_SHOWWINDOW = &H40
   Private Const HWND_DESKTOP = 0
   Private Const HWND_NOTOPMOST = -2
   Private Const HWND_TOP = 0
   Private Const HWND_TOPMOST = -1
   Private Const HWND_BOTTOM = 1

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long

Private Declare Function DrawTextA Lib "user32" (ByVal hdc As Long, ByVal lpStr
 As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr
 As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Const DT_LEFT = &H0&
    Private Const DT_TOP = &H0&
    Private Const DT_CENTER = &H1&
    Private Const DT_RIGHT = &H2&
    Private Const DT_VCENTER = &H4&
    Private Const DT_BOTTOM = &H8&
    Private Const DT_WORDBREAK = &H10&
    Private Const DT_SINGLELINE = &H20&
    Private Const DT_EXPANDTABS = &H40&
    Private Const DT_TABSTOP = &H80&
    Private Const DT_NOCLIP = &H100&
    Private Const DT_EXTERNALLEADING = &H200&
    Private Const DT_CALCRECT = &H400&
    Private Const DT_NOPREFIX = &H800
    Private Const DT_INTERNAL = &H1000&
    Private Const DT_WORD_ELLIPSIS = &H40000

Private Type OSVERSIONINFO
   dwVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion(0 To 127) As Byte
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA"
 (lpVersionInfo As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32_NT = 2


Private Type tItem
   sKey As String
   lIcon As Long
   bChecked As Boolean
   bEnabled As Boolean
   sText As String
   rcItem As RECT
   bMouseOver As Boolean
   bMouseDown As Boolean
End Type

Private m_tItems() As tItem
Private m_iItemCount As Long
Private m_hIml As Long
Private m_hWnd As Long
Private m_lWidth As Long
Private m_lMinWidth As Long
Private m_lHeight As Long
Private m_bIsNt As Boolean
Private m_bIsXp As Boolean
Private m_lItemHeight As Long
Private m_lIconWidth As Long
Private m_lIconHeight As Long
Private m_sDelimiter As String
Private m_bCheckBoxes As Boolean
Private m_bEnabled As Boolean

Private m_bDropDownMode As Boolean
Private m_ptrOwner As Long
Private m_bShowingPopup As Boolean
Private m_ptrPopup As Long

Private m_rcButton As RECT
Private m_bMouseOverButton As Boolean
Private m_bMouseDownButton As Boolean

Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event CheckChange(ByVal lIndex As Long, ByVal bCancel As Boolean)
Public Event RequestDropDownInstance(ctl As ddnMultiSelect)

Public Property Get Enabled() As Boolean
   Enabled = m_bEnabled
End Property
Public Property Let Enabled(ByVal value As Boolean)
   m_bEnabled = value
   UserControl.Enabled = value
   If Not (m_bDropDownMode) Then
      pPaint
   End If
   PropertyChanged "Enabled"
End Property

Public Property Get CheckBoxes() As Boolean
   CheckBoxes = m_bCheckBoxes
End Property
Public Property Let CheckBoxes(ByVal value As Boolean)
   m_bCheckBoxes = value
   EvalSize
   PropertyChanged "CheckBoxes"
End Property

Public Sub EndEdit()
   If (m_bShowingPopup) Then
      fPopupHide
   End If
End Sub

Public Property Get Delimiter() As String
   Delimiter = m_sDelimiter
End Property
Public Property Let Delimiter(ByVal value As String)
   m_sDelimiter = value
   If Not (m_bDropDownMode) Then
      pPaint
   End If
   PropertyChanged "Delimiter"
End Property

Public Property Get Selection() As String
Dim sSel As String
Dim i As Long
   For i = 1 To m_iItemCount
      If m_tItems(i).bChecked Then
         If Len(sSel) > 0 Then
            sSel = sSel & m_sDelimiter & " "
         End If
         sSel = sSel & m_tItems(i).sText
      End If
   Next i
   Selection = sSel
End Property
Public Property Let Selection(ByVal value As String)
Dim iPos As Long
Dim iNextPos As Long
Dim iItem As Long
Dim sItem As String
   For iItem = 1 To m_iItemCount
      m_tItems(iItem).bChecked = False
   Next iItem
   iPos = 1
   iNextPos = InStr(iPos, value, m_sDelimiter)
   Do While (iNextPos > 0)
      sItem = Trim(Mid(value, iPos, iNextPos - iPos))
      iItem = IndexForText(sItem)
      If (iItem > 0) Then
         m_tItems(iItem).bChecked = True
      End If
      iPos = iNextPos + Len(m_sDelimiter)
      iNextPos = InStr(iPos, value, m_sDelimiter)
   Loop
   If (iPos < Len(value)) Then
      sItem = Trim(Mid(value, iPos))
      iItem = IndexForText(sItem)
      If (iItem > 0) Then
         m_tItems(iItem).bChecked = True
      End If
   End If
   pPaint
End Property
Public Property Get hWnd() As Long
   hWnd = m_hWnd
End Property
Public Property Get hIml() As Long
   hIml = m_hIml
End Property
Public Property Let hIml(ByVal value As Long)
Dim rc As RECT
   m_hIml = value
   ImageList_GetImageRect m_hIml, 0, rc
   m_lIconWidth = rc.right - rc.left
   m_lIconHeight = rc.bottom - rc.top
   EvalSize
End Property
Public Property Get ItemCount() As Long
   ItemCount = m_iItemCount
End Property
Public Property Get ItemEnabled(ByVal nIndex As Long) As Boolean
   ItemEnabled = m_tItems(nIndex).bEnabled
End Property
Public Property Let ItemEnabled(ByVal nIndex As Long, ByVal value As Boolean)
   m_tItems(nIndex).bEnabled = value
End Property
Public Property Get ItemChecked(ByVal nIndex As Long) As Boolean
   ItemChecked = m_tItems(nIndex).bChecked
End Property
Public Property Let ItemChecked(ByVal nIndex As Long, ByVal value As Boolean)
   m_tItems(nIndex).bChecked = value
End Property
Friend Property Let fItemChecked(ByVal nIndex As Long, ByVal value As Long)
   m_tItems(nIndex).bChecked = value
   pPaint
End Property
Public Property Get ItemIcon(ByVal nIndex As Long) As Long
   ItemIcon = m_tItems(nIndex).lIcon
End Property
Public Property Let ItemIcon(ByVal nIndex As Long, ByVal value As Long)
   m_tItems(nIndex).lIcon = value
End Property
Public Property Get ItemText(ByVal nIndex As Long) As String
   ItemText = m_tItems(nIndex).sText
End Property
Public Property Let ItemText(ByVal nIndex As Long, ByVal value As String)
   m_tItems(nIndex).sText = value
End Property
Public Property Get ItemKey(ByVal nIndex As Long) As String
   ItemKey = m_tItems(nIndex).sKey
End Property
Public Property Let ItemKey(ByVal nIndex As Long, ByVal value As String)
   m_tItems(nIndex).sKey = value
End Property
Public Property Get IndexForText(ByVal value As String) As Long
Dim i As Long
   For i = 1 To m_iItemCount
      If (m_tItems(i).sText = value) Then
         IndexForText = i
         Exit For
      End If
   Next i
End Property
Public Property Get IndexForKey(ByVal value As String) As Long
Dim i As Long
   For i = 1 To m_iItemCount
      If (m_tItems(i).sText = value) Then
         IndexForKey = i
         Exit For
      End If
   Next i
End Property
Public Sub AddItem( _
      ByVal sKey As String, _
      Optional ByVal lIcon As Long = -1, _
      Optional ByVal sText As String = "", _
      Optional ByVal bChecked As Boolean = False, _
      Optional ByVal bEnabled As Boolean = True _
   )
   m_iItemCount = m_iItemCount + 1
   ReDim Preserve m_tItems(1 To m_iItemCount) As tItem
   With m_tItems(m_iItemCount)
      .sKey = sKey
      .sText = sText
      .lIcon = lIcon
      .bChecked = bChecked
      .bEnabled = bEnabled
   End With
   EvalSize
End Sub
Public Sub RemoveItem(ByVal lIndex As Long)
Dim i As Long
   If (m_iItemCount > 1) Then
      For i = m_iItemCount - 1 To lIndex Step -1
         LSet m_tItems(i + 1) = m_tItems(i)
      Next i
      m_iItemCount = m_iItemCount + 1
      ReDim Preserve m_tItems(1 To m_iItemCount) As tItem
   Else
      m_iItemCount = 0
      Erase m_tItems
   End If
   EvalSize
End Sub
Public Property Get DropDownShowing() As Boolean
   DropDownShowing = m_bShowingPopup
End Property
Public Property Get Font() As IFont
   Set Font = UserControl.Font
End Property
Public Property Let Font(iFnt As IFont)
   pSetFont iFnt
End Property
Public Property Set Font(iFnt As IFont)
   pSetFont iFnt
End Property
Private Sub pSetFont(iFnt As IFont)
   Set UserControl.Font = iFnt
   PropertyChanged "Font"
End Sub

Private Sub ShowPopup(ByVal hWndRelativeTo As Long, ByVal x As Long, ByVal y As
 Long)
Dim ctl As ddnMultiSelect
   If Not (m_bShowingPopup) Then
      RaiseEvent RequestDropDownInstance(ctl)
      If Not (ctl Is Nothing) Then
         Dim tP As POINTAPI
         tP.x = x
         tP.y = y
         ScreenToClient hWndRelativeTo, tP
         ctl.fSetData m_tItems, m_iItemCount
         ctl.fShowPopup Me, tP.x, tP.y
         m_bShowingPopup = True
         m_ptrPopup = ObjPtr(ctl)
         pPaint
      End If
   End If
End Sub
Friend Sub fPopupHide()
Dim ctl As ddnMultiSelect
   If (m_bShowingPopup) Then
      If Not (m_ptrPopup = 0) Then
         Set ctl = ObjectFromPtr(m_ptrPopup)
         ctl.fHidePopup
      End If
   End If
   m_bShowingPopup = False
End Sub

Friend Sub fSetData(items() As tItem, ByVal lCount As Long)
Dim i As Long
   m_iItemCount = lCount
   ReDim m_tItems(1 To m_iItemCount) As tItem
   For i = 1 To m_iItemCount
      LSet m_tItems(i) = items(i)
   Next i
   EvalSize
End Sub

Friend Sub fShowPopup(ctl As ddnMultiSelect, ByVal x As Long, ByVal y As Long)
Dim rc As RECT
Dim cM As cMonitor
Dim rcShow As RECT
   
   GetWindowRect ctl.hWnd, rc
   m_lMinWidth = rc.right - rc.left
   m_hIml = ctl.hIml
   EvalSize
   rcShow.left = x
   rcShow.top = y
   rcShow.right = rcShow.left + m_lWidth
   rcShow.bottom = rcShow.top + m_lHeight
   
   Set cM = New cMonitor
   cM.CreateFromPoint x, y
   If (cM.hMonitor = 0) Then
      If (rcShow.top < 0) Then
         OffsetRect rcShow, 0, -rcShow.top
      End If
      If (rcShow.bottom > Screen.Height \ Screen.TwipsPerPixelY) Then
         OffsetRect rcShow, 0, -(rc.bottom - rc.top) - (rcShow.bottom -
          rcShow.top)
      End If
      If (rcShow.left < 0) Then
         OffsetRect rcShow, -rcShow.left, 0
      End If
      If (rcShow.right > Screen.Width \ Screen.TwipsPerPixelY) Then
         OffsetRect rcShow, (Screen.Width \ Screen.TwipsPerPixelY -
          rcShow.right), 0
      End If
   Else
      If (rcShow.top < cM.WorkTop) Then
         OffsetRect rcShow, 0, -rcShow.top
      End If
      If (rcShow.bottom > cM.WorkTop + cM.WorkHeight) Then
         OffsetRect rcShow, 0, -(rc.bottom - rc.top) - (rcShow.bottom -
          rcShow.top)
      End If
      If (rcShow.left < cM.WorkLeft) Then
         OffsetRect rcShow, -rcShow.left, 0
      End If
      If (rcShow.right > cM.WorkLeft + cM.WorkWidth) Then
         OffsetRect rcShow, (cM.WorkLeft + cM.WorkWidth) - rcShow.right, 0
      End If
   End If
   
   m_bDropDownMode = True
   m_ptrOwner = ObjPtr(ctl)
   ' Set the style of the object so it works as a popup:
   Dim lStyle As Long
   lStyle = GetWindowLong(m_hWnd, GWL_EXSTYLE)
   lStyle = lStyle Or WS_EX_TOOLWINDOW
   lStyle = lStyle And Not (WS_EX_APPWINDOW)
   SetWindowLong m_hWnd, GWL_EXSTYLE, lStyle
   SetParent m_hWnd, HWND_DESKTOP
   SetProp m_hWnd, MAGIC_END_EDIT_IGNORE_WINDOW_PROP, 1
   SetWindowPos m_hWnd, HWND_TOPMOST, rcShow.left, rcShow.top, m_lWidth,
    m_lHeight, SWP_SHOWWINDOW
   pPaint
   
End Sub

Friend Sub fHidePopup()
   ShowWindow m_hWnd, SW_HIDE
   RemoveProp m_hWnd, MAGIC_END_EDIT_IGNORE_WINDOW_PROP
End Sub

Private Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
   If Not (lPtr = 0) Then
      ' Turn the pointer into an illegal, uncounted interface
      CopyMemory objT, lPtr, 4
      ' Do NOT hit the End button here! You will crash!
      ' Assign to legal reference
      Set ObjectFromPtr = objT
      ' Still do NOT hit the End button here! You will still crash!
      ' Destroy the illegal reference
      CopyMemory objT, 0&, 4
   End If
End Property

Private Sub VerInitialise()
   
   Dim tOSV As OSVERSIONINFO
   tOSV.dwVersionInfoSize = Len(tOSV)
   GetVersionEx tOSV
   
   m_bIsNt = ((tOSV.dwPlatformId And VER_PLATFORM_WIN32_NT) =
    VER_PLATFORM_WIN32_NT)
   If (tOSV.dwMajorVersion > 5) Then
      'm_bHasGradientAndTransparency = True
      m_bIsXp = True
      'm_bIs2000OrAbove = True
   ElseIf (tOSV.dwMajorVersion = 5) Then
      'm_bHasGradientAndTransparency = True
      'm_bIs2000OrAbove = True
      If (tOSV.dwMinorVersion >= 1) Then
         m_bIsXp = True
      End If
   ElseIf (tOSV.dwMajorVersion = 4) Then ' NT4 or 9x/ME/SE
      'If (tOSV.dwMinorVersion >= 10) Then
      '   m_bHasGradientAndTransparency = True
      'End If
   Else ' Too old
   End If
   
End Sub
Private Sub DrawText( _
      ByVal lhDC As Long, _
      ByVal sText As String, _
      ByVal lLength As Long, _
      tR As RECT, _
      ByVal lFlags As Long _
   )
Dim lPtr As Long
   If (m_bIsNt) Then
      lPtr = StrPtr(sText)
      If Not (lPtr = 0) Then ' NT4 crashes with ptr = 0
         DrawTextW lhDC, lPtr, -1, tR, lFlags
      End If
   Else
      DrawTextA lhDC, sText, -1, tR, lFlags
   End If
End Sub
Private Sub EvalSize()
Dim i As Long
Dim tR As RECT
Dim lMaxWidth As Long
Dim lDefWidth As Long
Dim lMaxHeight As Long
Dim lhDC As Long

   lhDC = UserControl.hdc
      
   If (m_hIml = 0) Then
      lMaxHeight = 20
      lDefWidth = 20
   Else
      lMaxHeight = m_lIconHeight + 4
      lDefWidth = (m_lIconWidth + 4) * 2
   End If
   lMaxWidth = lDefWidth
      
   
   For i = 1 To m_iItemCount
      tR.right = 256
      tR.bottom = 256
      DrawText lhDC, m_tItems(i).sText, -1, tR, DT_CALCRECT Or DT_SINGLELINE
      If (tR.bottom - tR.top + 4) > lMaxHeight Then
         lMaxHeight = tR.bottom - tR.top + 4
      End If
      If (tR.right - tR.left + 4 + lDefWidth) > lMaxWidth Then
         lMaxWidth = lDefWidth + (tR.right - tR.left + 4)
      End If
   Next i
   
   m_lWidth = lMaxWidth + 8
   If (m_lWidth < m_lMinWidth) Then
      m_lWidth = m_lMinWidth
   End If
   m_lItemHeight = lMaxHeight
   m_lHeight = lMaxHeight * m_iItemCount + 4
   
End Sub

Private Sub pPaint()
   If (m_bDropDownMode) Then
      pPaintAsDropDown
   Else
      pPaintAsSelector
   End If
End Sub

Private Sub pPaintAsSelector()
Dim lhDC As Long
Dim rc As RECT
Dim rcWork As RECT
Dim hBr As Long
Dim hBrOutline As Long
Dim lIconWidth As Long
Dim lIconHeight As Long
Dim hTheme As Long

   lIconWidth = IIf(m_hIml = 0, 16, m_lIconWidth)
   lIconHeight = IIf(m_hIml = 0, 16, m_lIconHeight)

   lhDC = UserControl.hdc
   GetClientRect m_hWnd, rc
   
   hBr = CreateSolidBrush(TranslateColor(vbWindowBackground))
   FillRect lhDC, rc, hBr
   DeleteObject hBr
   
   hBrOutline = CreateSolidBrush(TranslateColor(vbButtonShadow))
   
   If (m_bIsXp) Then
      On Error Resume Next
      hTheme = OpenThemeData(m_hWnd, StrPtr("EDIT"))
      On Error GoTo 0
   End If
   If (hTheme = 0) Then
      FrameRect lhDC, rc, hBrOutline
   Else
      DrawThemeBackground hTheme, lhDC, 1, IIf(m_bEnabled, 1, 4), rc, rc
      CloseThemeData hTheme
   End If

   InflateRect rc, -2, -2
   If (m_bEnabled And m_bMouseOverButton) Then
      hBr = CreateSolidBrush(TranslateColor(vbHighlight))
      FillRect lhDC, rc, hBr
      DeleteObject hBr
   End If

   LSet rcWork = rc
   rcWork.right = rcWork.right - lIconWidth
   If (m_bEnabled) Then
      If (m_bMouseOverButton) Then
         SetTextColor lhDC, TranslateColor(vbHighlightText)
         SetBkColor lhDC, TranslateColor(vbHighlight)
         SetBkMode lhDC, OPAQUE
      Else
         SetTextColor lhDC, TranslateColor(vbWindowText)
         SetBkMode lhDC, TRANSPARENT
      End If
   Else
      SetTextColor lhDC, TranslateColor(vbButtonShadow)
      SetBkMode lhDC, TRANSPARENT
   End If
   DrawText lhDC, Selection, -1, rcWork, DT_SINGLELINE Or DT_VCENTER Or
    DT_END_ELLIPSIS
   
   LSet m_rcButton = rcWork
   m_rcButton.left = rcWork.right
   m_rcButton.right = m_rcButton.left + lIconWidth

   If (m_bIsXp) Then
      On Error Resume Next
      hTheme = OpenThemeData(m_hWnd, StrPtr("COMBOBOX"))
      On Error GoTo 0
   End If
   
   If (hTheme = 0) Then
      If (m_bShowingPopup) Then
         hBr = CreateSolidBrush(BlendColor(vbHighlight, vbButtonFace)) ' ,192))
      ElseIf (m_bMouseOverButton) Then
   '      hBr = CreateSolidBrush(BlendColor(vbHighlight, vbButtonFace))
   '   Else
         hBr = CreateSolidBrush(TranslateColor(vbButtonFace))
      End If
      FillRect lhDC, m_rcButton, hBr
      DeleteObject hBr
   
      UtilDrawSplitGlyph lhDC, m_rcButton.left, m_rcButton.top,
       m_rcButton.right - m_rcButton.left, m_rcButton.bottom - m_rcButton.top,
       m_bEnabled, &H0&
   
      If (m_bMouseOverButton Or m_bShowingPopup) Then
         hBr = CreateSolidBrush(TranslateColor(vbHighlight))
         FrameRect lhDC, m_rcButton, hBr
         DeleteObject hBr
      Else
         FrameRect lhDC, m_rcButton, hBrOutline
      End If
   
   Else
      InflateRect m_rcButton, 1, 1
      If (m_bEnabled) Then
         If (m_bShowingPopup) Then
            DrawThemeBackground hTheme, lhDC, 1, 3, m_rcButton, m_rcButton
         Else
            DrawThemeBackground hTheme, lhDC, 1, 1, m_rcButton, m_rcButton
         End If
      Else
         DrawThemeBackground hTheme, lhDC, 1, 4, m_rcButton, m_rcButton
      End If
      CloseThemeData hTheme
   End If
   
   DeleteObject hBrOutline
      
   UserControl.Refresh

End Sub

Private Sub pPaintAsDropDown()
Dim rc As RECT
Dim i As Long
Dim rcItem As RECT
Dim rcWork As RECT
Dim rcWork2 As RECT
Dim lhDC As Long
Dim hBr As Long
Dim lIconWidth As Long
Dim lIconHeight As Long
Dim hTheme As Long

   lIconWidth = IIf(m_hIml = 0, 16, m_lIconWidth)
   lIconHeight = IIf(m_hIml = 0, 16, m_lIconHeight)

   lhDC = UserControl.hdc
   GetClientRect m_hWnd, rc
   
   hBr = CreateSolidBrush(TranslateColor(vbWindowBackground))
   FillRect lhDC, rc, hBr
   DeleteObject hBr
   
   hBr = CreateSolidBrush(TranslateColor(vbButtonShadow))
   FrameRect lhDC, rc, hBr
   DeleteObject hBr

   If (m_bIsXp) Then
      On Error Resume Next
      hTheme = OpenThemeData(m_hWnd, StrPtr("BUTTON"))
      On Error GoTo 0
   End If

   LSet rcItem = rc
   InflateRect rcItem, -2, 0
   rcItem.top = 2
   For i = 1 To m_iItemCount
      rcItem.bottom = rcItem.top + m_lItemHeight
      LSet m_tItems(i).rcItem = rcItem
      If (m_tItems(i).bMouseOver) Then
         hBr = CreateSolidBrush(BlendColor(vbHighlight, vbWindowBackground))
         FillRect lhDC, rcItem, hBr
         DeleteObject hBr
         hBr = CreateSolidBrush(TranslateColor(vbHighlight))
         FrameRect lhDC, rcItem, hBr
         DeleteObject hBr
      End If
         
      ' Check box:
      LSet rcWork = rcItem
      InflateRect rcWork, 0, -2
      rcWork.left = rcWork.left + 2
      rcWork.right = rcWork.left + lIconWidth
      LSet rcWork2 = rcWork
      rcWork2.top = ((rcWork.bottom - rcWork.top) - lIconHeight) \ 2
      rcWork2.bottom = rcWork2.top + lIconHeight
            
      If (hTheme = 0) Then
         hBr = CreateSolidBrush(TranslateColor(vbWindowText))
         FrameRect lhDC, rcWork, hBr
         LSet rcWork2 = rcWork
         InflateRect rcWork2, -1, -1
         FrameRect lhDC, rcWork2, hBr
         DeleteObject hBr
         If (m_tItems(i).bChecked) Then
            UtilDrawCheckGlyph lhDC, rcWork2.left, rcWork2.top, rcWork2.right -
             rcWork2.left, rcWork2.bottom - rcWork2.top, True, &H0&
         End If
      Else
         If (m_tItems(i).bChecked) Then
            DrawThemeBackground hTheme, lhDC, 3, 5, rcWork, rcWork
         Else
            DrawThemeBackground hTheme, lhDC, 3, 1, rcWork, rcWork
         End If
      End If
      
      If Not (m_hIml = 0) Then
         ' Icon
         rcWork.left = rcWork.left + lIconWidth + 4
         rcWork.right = rcWork.left + lIconWidth
         ImageList_Draw m_hIml, m_tItems(i).lIcon, lhDC, rcWork.left,
          rcWork.top, ILD_TRANSPARENT
      End If
      
      ' Text
      rcWork.left = rcWork.left + lIconWidth + 4
      rcWork.right = rcItem.right - 2
      DrawText lhDC, m_tItems(i).sText, -1, rcWork, DT_LEFT Or DT_SINGLELINE Or
       DT_VCENTER Or DT_END_ELLIPSIS
      
      rcItem.top = rcItem.top + m_lItemHeight
   Next i
   
   If Not (hTheme = 0) Then
      CloseThemeData hTheme
   End If
   
   UserControl.Refresh
   
End Sub

Private Property Get BlendColor( _
      ByVal oColorFrom As OLE_COLOR, _
      ByVal oColorTo As OLE_COLOR, _
      Optional ByVal Alpha As Long = 128 _
   ) As Long
Dim lCFrom As Long
Dim lCTo As Long
   lCFrom = TranslateColor(oColorFrom)
   lCTo = TranslateColor(oColorTo)
Dim lSrcR As Long
Dim lSrcG As Long
Dim lSrcB As Long
Dim lDstR As Long
Dim lDstG As Long
Dim lDstB As Long
   lSrcR = lCFrom And &HFF
   lSrcG = (lCFrom And &HFF00&) \ &H100&
   lSrcB = (lCFrom And &HFF0000) \ &H10000
   lDstR = lCTo And &HFF
   lDstG = (lCTo And &HFF00&) \ &H100&
   lDstB = (lCTo And &HFF0000) \ &H10000
     
   
   BlendColor = RGB( _
      ((lSrcR * Alpha) / 255) + ((lDstR * (255 - Alpha)) / 255), _
      ((lSrcG * Alpha) / 255) + ((lDstG * (255 - Alpha)) / 255), _
      ((lSrcB * Alpha) / 255) + ((lDstB * (255 - Alpha)) / 255) _
      )
      
End Property



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

Private Sub UtilDrawCheckGlyph( _
      ByVal hdc As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long _
   )
Dim lCentreY As Long
Dim lCentreX As Long
Dim tJ As POINTAPI
Dim hPen As Long
Dim hPenOld As Long
   
   lCentreX = lLeft + lWidth \ 2 - 1
   lCentreY = lTop + lHeight \ 2
   
   hPen = CreatePen(PS_SOLID, 1, &H0)
   hPenOld = SelectObject(hdc, hPenOld)
   
   MoveToEx hdc, lCentreX - 3, lCentreY, tJ
   LineTo hdc, lCentreX - 1, lCentreY + 2
   MoveToEx hdc, lCentreX - 3, lCentreY + 1, tJ
   LineTo hdc, lCentreX - 1, lCentreY + 3
   
   MoveToEx hdc, lCentreX - 1, lCentreY + 3, tJ
   LineTo hdc, lCentreX + 5, lCentreY - 3
   MoveToEx hdc, lCentreX - 1, lCentreY + 2, tJ
   LineTo hdc, lCentreX + 5, lCentreY - 4
   
   SelectObject hdc, hPenOld
   DeleteObject hPen
   
End Sub
Public Sub UtilDrawSplitGlyph( _
      ByVal hdc As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long, _
      ByVal bEnabled As Boolean, _
      ByVal color As Long _
   )
Dim lCentreY As Long
Dim lCentreX As Long
   
   lCentreX = lLeft + lWidth \ 2
   lCentreY = lTop + lHeight \ 2

   SetPixel hdc, lCentreX - 2, lCentreY - 1, color
   SetPixel hdc, lCentreX - 1, lCentreY - 1, color
   SetPixel hdc, lCentreX, lCentreY - 1, color
   SetPixel hdc, lCentreX + 1, lCentreY - 1, color
   SetPixel hdc, lCentreX + 2, lCentreY - 1, color
   SetPixel hdc, lCentreX - 1, lCentreY, color
   SetPixel hdc, lCentreX, lCentreY, color
   SetPixel hdc, lCentreX + 1, lCentreY, color
   SetPixel hdc, lCentreX, lCentreY + 1, color
   
End Sub

Private Function plHitTest() As Long
Dim tP As POINTAPI
Dim rc As RECT
Dim i As Long
   If (m_bDropDownMode) Then
      GetCursorPos tP
      GetWindowRect m_hWnd, rc
      If Not (PtInRect(rc, tP.x, tP.y) = 0) Then
         ScreenToClient m_hWnd, tP
         For i = 1 To m_iItemCount
            If Not (PtInRect(m_tItems(i).rcItem, tP.x, tP.y) = 0) Then
               plHitTest = i
               Exit For
            End If
         Next i
      End If
   End If
End Function

Private Sub pInitialise()
   m_hWnd = UserControl.hWnd
   VerInitialise
End Sub

Private Sub selectNext(ByVal iDir As Long)
Dim i As Long
Dim iIndexSel As Long
Dim iNewIndexSel As Long
   
   If (m_iItemCount = 0) Then
      Exit Sub
   End If
   
   For i = 1 To m_iItemCount
      If (m_tItems(i).bMouseOver) Then
         iIndexSel = i
         Exit For
      End If
   Next i
   
   If (iIndexSel = 0) Then
      If (iDir > 0) Then
         iNewIndexSel = 1
      Else
         iNewIndexSel = m_iItemCount
      End If
   Else
      iNewIndexSel = iIndexSel + iDir
      If (iNewIndexSel > m_iItemCount) Then
         iNewIndexSel = m_iItemCount
      ElseIf (iNewIndexSel < 1) Then
         iNewIndexSel = 1
      End If
   End If
   
   If Not (iNewIndexSel = iIndexSel) Then
      If (iIndexSel > 0) Then
         m_tItems(iIndexSel).bMouseOver = False
      End If
      m_tItems(iNewIndexSel).bMouseOver = True
      pPaint
   End If
   
   
End Sub

Private Sub checkSelection()
Dim i As Long
Dim iIndexSel As Long
Dim ctl As ddnMultiSelect
   
   If (m_iItemCount = 0) Then
      Exit Sub
   End If
   
   For i = 1 To m_iItemCount
      If (m_tItems(i).bMouseOver) Then
         iIndexSel = i
         Exit For
      End If
   Next i
   
   If (iIndexSel > 0) Then
      m_tItems(iIndexSel).bChecked = Not (m_tItems(iIndexSel).bChecked)
      Set ctl = ObjectFromPtr(m_ptrOwner)
      ctl.fItemChecked(iIndexSel) = m_tItems(iIndexSel).bChecked
      pPaint
   End If
   
End Sub

Friend Sub fPopupKeyDown(KeyCode As Integer, Shift As Integer)
   
   Select Case KeyCode
   Case vbKeyUp, vbKeyLeft
      selectNext -1
   Case vbKeyDown, vbKeyRight
      selectNext 1
   Case vbKeyPageUp
      selectNext -8
   Case vbKeyPageDown
      selectNext 8
   Case vbKeyHome
      selectNext -10000
   Case vbKeyEnd
      selectNext 10000
   Case vbKeyReturn, vbKeySpace
      checkSelection
   Case vbKeyEscape
      fHidePopup
   End Select
   
End Sub


Private Sub tmrLostMouse_Timer()
   '
Dim tP As POINTAPI
Dim rc As RECT
Dim i As Long
Dim bChanged As Boolean
Dim bOutsideWin As Boolean

   GetCursorPos tP
   GetWindowRect m_hWnd, rc
   bOutsideWin = (PtInRect(rc, tP.x, tP.y) = 0)

   If (m_bDropDownMode) Then
      If (bOutsideWin) Then
         tmrLostMouse.Enabled = False
         For i = 1 To m_iItemCount
            If (m_tItems(i).bMouseOver) Then
               m_tItems(i).bMouseOver = False
               bChanged = True
            End If
         Next i
         If (bChanged) Then
            pPaint
         End If
      End If
   Else
      If m_bMouseOverButton Then
         If Not (m_bShowingPopup) Then
            If (bOutsideWin) Then
               tmrLostMouse.Enabled = False
               m_bMouseOverButton = False
               pPaint
            End If
         End If
      End If
   End If
   '
End Sub


Private Sub UserControl_Initialize()
   
   ' Set defaults
   m_bEnabled = True
   m_bCheckBoxes = True
   m_sDelimiter = ","
   
End Sub

Private Sub UserControl_InitProperties()
   pInitialise
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
   If (m_bDropDownMode) Then
      fPopupKeyDown KeyCode, Shift
   Else
      If m_bShowingPopup Then
         Select Case KeyCode
         Case vbKeyEscape
            fPopupHide
         Case Else
            Dim ctl As ddnMultiSelect
            Set ctl = ObjectFromPtr(m_ptrPopup)
            ctl.fPopupKeyDown KeyCode, Shift
         End Select
      Else
         RaiseEvent KeyDown(KeyCode, Shift)
         Select Case KeyCode
         Case vbKeyDown, vbKeyF4
            Dim rc As RECT
            GetWindowRect m_hWnd, rc
            ShowPopup 0, rc.left, rc.bottom
         End Select
      End If
   End If
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
   RaiseEvent KeyPress(KeyAscii)
   If (m_bDropDownMode) Then
   Else
   End If
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
   RaiseEvent KeyUp(KeyCode, Shift)
   If (m_bDropDownMode) Then
   Else
   End If
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As
 Single, y As Single)
Dim ctl As ddnMultiSelect
Dim lItem As Long
Dim rc As RECT
   '
   If (m_bDropDownMode) Then
      tmrLostMouse.Enabled = False
      lItem = plHitTest()
      If (lItem > 0) Then
         m_tItems(lItem).bChecked = Not (m_tItems(lItem).bChecked)
         Set ctl = ObjectFromPtr(m_ptrOwner)
         ctl.fItemChecked(lItem) = m_tItems(lItem).bChecked
         m_tItems(lItem).bMouseDown = True
         m_tItems(lItem).bMouseOver = True
         pPaint
      End If
   Else
      If (m_bShowingPopup) Then
         Set ctl = ObjectFromPtr(m_ptrPopup)
         ctl.fHidePopup
         m_bShowingPopup = False
         pPaint
      Else
         GetWindowRect m_hWnd, rc
         ShowPopup 0, rc.left, rc.bottom
      End If
   End If
   '
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As
 Single, y As Single)
Dim lItem As Long
Dim i As Long
Dim bChanged As Boolean
   '
   If (m_bDropDownMode) Then
      lItem = plHitTest()
      For i = 1 To m_iItemCount
         If Not (m_tItems(i).bMouseOver) = (i = lItem) Then
            m_tItems(i).bMouseOver = (i = lItem)
            bChanged = True
         End If
      Next i
      If (bChanged) Then
         pPaint
      End If
      If (Button = 0) Then
         tmrLostMouse.Enabled = True
      End If
   Else
      If Not (m_bMouseOverButton) Then
         m_bMouseOverButton = True
         pPaint
         If (Button = 0) Then
            tmrLostMouse.Enabled = True
         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 bChanged As Boolean
Dim i As Long
   '
   If (m_bDropDownMode) Then
      For i = 1 To m_iItemCount
         If m_tItems(i).bMouseDown Then
            m_tItems(i).bMouseDown = False
            bChanged = True
         End If
      Next i
      If (bChanged) Then
         pPaint
      End If
   Else
   
   End If
   '
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   pInitialise
   
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.Size = 8.25
   Set Font = PropBag.ReadProperty("Font", sFnt)
   Delimiter = PropBag.ReadProperty("Delimiter", ",")
   CheckBoxes = PropBag.ReadProperty("CheckBoxes", True)
   Enabled = PropBag.ReadProperty("Enabled", True)
End Sub

Private Sub UserControl_Resize()
   pPaint
End Sub

Private Sub UserControl_Show()
   pPaint
End Sub

Private Sub UserControl_Terminate()
   If (m_bDropDownMode) Then
      fHidePopup
   End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   Dim sFnt As New StdFont
   sFnt.Name = "Tahoma"
   sFnt.Size = 8.25
   PropBag.WriteProperty "Font", Font, sFnt
   PropBag.WriteProperty "Delimiter", Delimiter, ","
   PropBag.WriteProperty "CheckBoxes", CheckBoxes, True
   PropBag.WriteProperty "Enabled", Enabled, True
End Sub