vbAccelerator - Contents of code file: cSimpleODListBox.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cSimpleODListBox"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements ISubclass

' Owner drawn control messages:
Private Const WM_MEASUREITEM = &H2C
Private Const WM_DRAWITEM = &H2B
Private Const WM_DESTROY = &H2
Private Const WM_SETREDRAW = &HB
Private Const WM_COMMAND = &H111

' Owner draw style types:
Private Const ODS_CHECKED = &H8
Private Const ODS_DISABLED = &H4
Private Const ODS_FOCUS = &H10
Private Const ODS_GRAYED = &H2
Private Const ODS_SELECTED = &H1
Private Const ODS_COMBOBOXEDIT = &H1000
' Owner draw action types:
Private Const ODA_DRAWENTIRE = &H1
Private Const ODA_FOCUS = &H4
Private Const ODA_SELECT = &H2

Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 String) As Long
Private Declare Function SendMessageByLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
 hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const LBN_SELCHANGE = 1

Private Const LB_GETITEMDATA = &H199
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_GETCURSEL = &H188
Private Const LB_GETITEMRECT = &H198
Private Const LB_GETSEL = &H187

' rect
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

' Owner draw item measure:
Private Type MEASUREITEMSTRUCT
   CtlType As Long
   CtlID As Long
   ItemId As Long
   itemWidth As Long
   itemHeight As Long
   itemData As Long
End Type

' Owner draw item draw:
Private Type DRAWITEMSTRUCT
   CtlType As Long
   CtlID As Long
   ItemId As Long
   ItemAction As Long
   ItemState As Long
   hwndItem As Long
   hdc As Long
   rcItem As RECT
   itemData As Long
End Type

' Memory functions:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
' Text functions:
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
    Private Const DT_BOTTOM = &H8
    Private Const DT_CENTER = &H1
    Private Const DT_LEFT = &H0
    Private Const DT_CALCRECT = &H400
    Private Const DT_WORDBREAK = &H10
    Private Const DT_VCENTER = &H4
    Private Const DT_TOP = &H0
    Private Const DT_TABSTOP = &H80
    Private Const DT_SINGLELINE = &H20
    Private Const DT_RIGHT = &H2
    Private Const DT_NOCLIP = &H100
    Private Const DT_INTERNAL = &H1000
    Private Const DT_EXTERNALLEADING = &H200
    Private Const DT_EXPANDTABS = &H40
    Private Const DT_CHARSTREAM = 4
    Private Const DT_NOPREFIX = &H800
    Private Const DT_EDITCONTROL = &H2000&
    Private Const DT_PATH_ELLIPSIS = &H4000&
    Private Const DT_END_ELLIPSIS = &H8000&
    Private Const DT_MODIFYSTRING = &H10000
    Private Const DT_RTLREADING = &H20000
    Private Const DT_WORD_ELLIPSIS = &H40000

Private 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 OPAQUE = 2
    Private Const TRANSPARENT = 1
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) 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 Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex 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 GetFocus Lib "user32" () As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect
 As RECT) As Long

'/* flags for DrawFrameControl */
Private Enum DFCFlags
   DFC_CAPTION = 1
   DFC_MENU = 2
   DFC_SCROLL = 3
   DFC_BUTTON = 4
   'Win98/2000 only
   DFC_POPUPMENU = 5
End Enum

Private Enum DFCCaptionTypeFlags
   ' Caption types:
   DFCS_CAPTIONCLOSE = &H0&
   DFCS_CAPTIONMIN = &H1&
   DFCS_CAPTIONMAX = &H2&
   DFCS_CAPTIONRESTORE = &H3&
   DFCS_CAPTIONHELP = &H4&
End Enum
Private Enum DFCMenuTypeFlags
   ' Menu types:
   DFCS_MENUARROW = &H0&
   DFCS_MENUCHECK = &H1&
   DFCS_MENUBULLET = &H2&
   DFCS_MENUARROWRIGHT = &H4&
End Enum
Private Enum DFCScrollTypeFlags
   ' Scroll types:
   DFCS_SCROLLUP = &H0&
   DFCS_SCROLLDOWN = &H1&
   DFCS_SCROLLLEFT = &H2&
   DFCS_SCROLLRIGHT = &H3&
   DFCS_SCROLLCOMBOBOX = &H5&
   DFCS_SCROLLSIZEGRIP = &H8&
   DFCS_SCROLLSIZEGRIPRIGHT = &H10&
End Enum
Private Enum DFCButtonTypeFlags
   ' Button types:
   DFCS_BUTTONCHECK = &H0&
   DFCS_BUTTONRADIOIMAGE = &H1&
   DFCS_BUTTONRADIOMASK = &H2&
   DFCS_BUTTONRADIO = &H4&
   DFCS_BUTTON3STATE = &H8&
   DFCS_BUTTONPUSH = &H10&
End Enum
Private Enum DFCStateTypeFlags
   ' Styles:
   DFCS_INACTIVE = &H100&
   DFCS_PUSHED = &H200&
   DFCS_CHECKED = &H400&
   ' Win98/2000 only
   DFCS_TRANSPARENT = &H800&
   DFCS_HOT = &H1000&
   'End Win98/2000 only
   DFCS_ADJUSTRECT = &H2000&
   DFCS_FLAT = &H4000&
   DFCS_MONO = &H8000&
End Enum

Private Declare Function DrawFrameControl Lib "user32" (ByVal lhDC As Long, tR
 As RECT, ByVal eFlag As DFCFlags, ByVal eStyle As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long

Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal
 nSavedDC As Long) As Long

Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long,
 lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long)
 As Long

Private m_hWnd As Long
Private m_hWndListBox As Long
Private m_hIml As Long
Private m_bRedraw As Boolean

Public Sub Redraw(lstThis As ListBox, ByVal bState As Boolean)
   lstThis.Visible = bState
   'SendMessage lstThis.hwnd, WM_SETREDRAW, Abs(bState), ByVal 0&
   'm_bRedraw = bState
End Sub

Private Sub pSubTreeSet(lstThis As ListBox, ByVal lIndex As Long, ByRef bSel As
 Boolean, ByRef bNoSel As Boolean, ByRef lParent As Long)
Dim i As Long
Dim lIndent As Long
Dim lThisIndent As Long

   lIndent = Indent(lstThis, lIndex)

   lParent = -1
   bSel = False
   bNoSel = False
   
   ' Check for state @ this level:
   i = lIndex
   Do
      If i >= 0 Then
         lThisIndent = Indent(lstThis, i)
         If lThisIndent < lIndent Then
            lParent = i
            Exit Do
         ElseIf lThisIndent = lIndent Then
            If lstThis.Selected(i) Then
               bSel = True
            Else
               bNoSel = True
            End If
         End If
         If bSel And bNoSel Then
            Exit Do
         End If
      Else
         Exit Do
      End If
      i = i - 1
   Loop
   
   If bNoSel And bSel Then
      Exit Sub
   End If
   
   i = lIndex
   Do
      i = i + 1
      If i < lstThis.ListCount Then
         lThisIndent = Indent(lstThis, i)
         If lThisIndent < lIndent Then
            Exit Do
         ElseIf lThisIndent = lIndent Then
            If lstThis.Selected(i) Then
               bSel = True
            Else
               bNoSel = True
            End If
         End If
         If bSel And bNoSel Then
            Exit Do
         End If
      Else
         Exit Do
      End If
   Loop
   

End Sub

Public Sub TreeSet(lstThis As ListBox, ByVal lIndex As Long)
Static bInHere As Boolean
   If Not bInHere Then
      bInHere = True
      Redraw lstThis, False
      pTreeset lstThis, lIndex
      lstThis.ListIndex = lIndex
      bInHere = False
      Redraw lstThis, True
   End If
End Sub
Private Sub pTreeset(lstThis As ListBox, ByVal lIndex As Long)
Dim bSel As Boolean, bNoSel As Boolean
Dim lParent As Long
Dim i As Long
Dim lIndent As Long, lThisIndent As Long
Dim lNextIndex As Long
         
   i = lIndex
   lIndent = Indent(lstThis, lIndex)
   Do
      i = i + 1
      If i < lstThis.ListCount Then
         lThisIndent = Indent(lstThis, i)
         If lThisIndent <= lIndent Then
            Exit Do
         ElseIf lThisIndent > lIndent Then
            lstThis.Selected(i) = lstThis.Selected(lIndex)
         End If
      Else
         Exit Do
      End If
   Loop
         
   If lIndent > 0 Then
      pSubTreeSet lstThis, lIndex, bSel, bNoSel, lParent
      If bSel And bNoSel Then
      Else
         If lParent > -1 Then
            If bSel Then
               lstThis.Selected(lParent) = True
            Else
               lstThis.Selected(lParent) = False
            End If
         End If
         lNextIndex = lParent
      End If
   End If
   
   If lNextIndex > 0 Then
      pTreeset lstThis, lNextIndex
   End If
         
End Sub
Public Sub Attach(ByVal hwnd As Long)
   Detach
   m_hWndListBox = hwnd
   m_hWnd = GetParent(hwnd)
   AttachMessage Me, m_hWnd, WM_DRAWITEM
   AttachMessage Me, m_hWnd, WM_MEASUREITEM
   AttachMessage Me, m_hWnd, WM_COMMAND
   AttachMessage Me, m_hWndListBox, WM_DESTROY
End Sub
Public Sub Detach()
   If m_hWnd Then
      DetachMessage Me, m_hWnd, WM_DRAWITEM
      DetachMessage Me, m_hWnd, WM_MEASUREITEM
      DetachMessage Me, m_hWnd, WM_COMMAND
      DetachMessage Me, m_hWndListBox, WM_DESTROY
      m_hWnd = 0
      m_hWndListBox = 0
   End If
End Sub
Public Property Let ImageList(ByVal hIml As Long)
   m_hIml = hIml
End Property
Public Sub AddItem(lstThis As ListBox, ByVal sText As String, ByVal lIcon As
 Long, ByVal lIndent As Long)
Dim lItemData As Long
   lItemData = (lIcon And &HFFFF&) Or ((lIndent And &HFF&) * &H10000)
   lstThis.AddItem sText
   lstThis.itemData(lstThis.NewIndex) = lItemData
   lstThis.Selected(lstThis.NewIndex) = True
End Sub
Public Property Get Indent(lstThis As ListBox, ByVal lIndex As Long) As Long
Dim lItemData As Long
   lItemData = lstThis.itemData(lIndex)
   Indent = (lItemData And &HFF0000) \ &H10000
End Property
Public Property Let Indent(lstThis As ListBox, ByVal lIndex As Long, ByVal
 lIndent As Long)
Dim lItemData As Long
   lItemData = lstThis.itemData(lIndex)
   lItemData = lItemData And Not &HFF0000
   lItemData = lItemData Or (lIndent And &HFF&) * &H10000
   lstThis.itemData(lIndex) = lItemData
End Property
Public Property Get Icon(lstThis As ListBox, ByVal lIndex As Long) As Long
Dim lItemData As Long
   lItemData = lstThis.itemData(lIndex)
   Icon = (lItemData And &HFFFF&)
End Property
Public Property Let Icon(lstThis As ListBox, ByVal lIndex As Long, ByVal lIcon
 As Long)
Dim lItemData As Long
   lItemData = lstThis.itemData(lIndex)
   lItemData = lItemData And Not &HFFFF&
   lItemData = lItemData Or (lIcon And &HFFFF&)
   lstThis.itemData(lIndex) = lItemData
End Property

Private Sub Class_Initialize()
   m_bRedraw = True
End Sub

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

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   Select Case CurrentMessage
   Case WM_COMMAND
      ISubclass_MsgResponse = emrPostProcess
   Case WM_DRAWITEM, WM_MEASUREITEM
      ISubclass_MsgResponse = emrConsume
   Case WM_DESTROY
      ISubclass_MsgResponse = emrPreprocess
   End Select
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_COMMAND
      If wParam \ &H10000 = LBN_SELCHANGE Then
         '
      End If
   Case WM_DRAWITEM
      If Not m_bRedraw Then
         Exit Function
      End If
      Dim tDIS As DRAWITEMSTRUCT
      CopyMemory tDIS, ByVal lParam, Len(tDIS)
      If tDIS.hwndItem = m_hWndListBox Then
         DrawItem tDIS
      End If
   Case WM_MEASUREITEM
      Dim tMIS As MEASUREITEMSTRUCT
      CopyMemory tMIS, ByVal lParam, Len(tMIS)
      tMIS.itemHeight = 20
      CopyMemory ByVal lParam, tMIS, Len(tMIS)
   Case WM_DESTROY
      Detach
   End Select
End Function

Private Sub DrawItem(tDIS As DRAWITEMSTRUCT)
Dim bEnabled As Boolean
Dim bSelected As Boolean
Dim lIndex As Long
Dim lItemData As Long
Dim lIcon As Long
Dim lIndent As Long
Dim lListIndex As Long
Dim lLen As Long
Dim sBuf As String
Dim tR As RECT
Dim lFlag As Long
Dim lLeft As Long
Dim hBr As Long
Dim lBkMode As Long
Dim lBkColor As Long
Dim lSaveDC As Long
Dim iPos As Long
Static lLastDraw As Long

   lSaveDC = SaveDC(tDIS.hdc)

   bEnabled = Not ((tDIS.ItemState And ODS_DISABLED) = ODS_DISABLED)
   bSelected = ((tDIS.ItemState And ODS_SELECTED) = ODS_SELECTED)
   lIndex = tDIS.ItemId
   lItemData = SendMessageByLong(m_hWndListBox, LB_GETITEMDATA, lIndex, 0)
   lIndent = (lItemData And &H7FFF0000) \ &H10000
   lIcon = (lItemData And &HFFFF&)
   lListIndex = SendMessageByLong(m_hWndListBox, LB_GETCURSEL, 0, 0)
   
   tDIS.rcItem.Left = tDIS.rcItem.Left + 20 * lIndent
   If lListIndex = lIndex Then
      If lLastDraw > -1 And lLastDraw <> lListIndex Then
         pRedrawItem tDIS.hdc, lLastDraw
         lLastDraw = -1
      End If
      hBr = GetSysColorBrush(vbHighlight And &H1F&)
      LSet tR = tDIS.rcItem
      tR.Right = tR.Right - 2
      FillRect tDIS.hdc, tR, hBr
      DeleteObject hBr
      lLastDraw = lListIndex
      If GetFocus() = tDIS.hwndItem Then
         DrawFocusRect tDIS.hdc, tR
      End If
   End If
   LSet tR = tDIS.rcItem
   tR.Right = tR.Left + 20
   InflateRect tR, -1, -1
   OffsetRect tR, 1, 1
   lFlag = DFCS_BUTTONCHECK Or DFCS_FLAT
   If bSelected Then
      lFlag = lFlag Or DFCS_CHECKED
   End If
   DrawFrameControl tDIS.hdc, tR, DFC_BUTTON, lFlag
   LSet tR = tDIS.rcItem
   lLen = SendMessageByLong(m_hWndListBox, LB_GETTEXTLEN, lIndex, 0)
   If lLen > 0 Then
      sBuf = String$(lLen, 0)
      SendMessageByString m_hWndListBox, LB_GETTEXT, lIndex, sBuf
      iPos = InStr(sBuf, vbTab)
      If iPos > 1 Then
         sBuf = Left$(sBuf, iPos - 1)
      End If
   End If
   tR.Left = tR.Left + 20
   ImageList_Draw m_hIml, lIcon, tDIS.hdc, tR.Left + 2, tR.Top, ILD_TRANSPARENT
   lLeft = tR.Left + 20
   LSet tR = tDIS.rcItem
   tR.Left = lLeft
   
   If Len(sBuf) > 0 Then
      If lListIndex = lIndex Then
         SetTextColor tDIS.hdc, GetSysColor(vbHighlightText And &H1F&)
      End If
      lBkMode = SetBkMode(tDIS.hdc, TRANSPARENT)
      DrawText tDIS.hdc, sBuf, -1, tR, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
       Or DT_END_ELLIPSIS
      SetBkMode tDIS.hdc, lBkMode
   End If
   
   RestoreDC tDIS.hdc, lSaveDC
   
End Sub
Private Sub pRedrawItem(ByVal lhDC As Long, ByVal lIndex As Long)
Dim rc As RECT
Dim hBr As Long
Dim tR As RECT
Dim lLeft As Long
Dim lLen As Long
Dim lFlag As Long
Dim sBuf As String
Dim lBkColor As Long
Dim bSelected As Boolean
Dim lItemData As Long
Dim lListIndex As Long
Dim lIcon As Long
Dim lIndent As Long
Dim lBkMode As Long
Dim iPos As Long

   ' Get the rectangle for this item:
   SendMessage m_hWndListBox, LB_GETITEMRECT, lIndex, rc
   lItemData = SendMessageByLong(m_hWndListBox, LB_GETITEMDATA, lIndex, 0)
   lIndent = (lItemData And &H7FFF0000) \ &H10000
   lIcon = (lItemData And &HFFFF&)
   rc.Left = rc.Left + 20 * lIndent
      
   hBr = GetSysColorBrush(vbWindowBackground And &H1F&)
   FillRect lhDC, rc, hBr
   DeleteObject hBr
   
   LSet tR = rc
   tR.Right = tR.Left + 20
   InflateRect tR, -1, -1
   OffsetRect tR, 1, 1
   lFlag = DFCS_BUTTONCHECK Or DFCS_FLAT
   bSelected = SendMessageByLong(m_hWndListBox, LB_GETSEL, lIndex, 0)
   If bSelected Then
      lFlag = lFlag Or DFCS_CHECKED
   End If
   DrawFrameControl lhDC, tR, DFC_BUTTON, lFlag
   LSet tR = rc
   lLen = SendMessageByLong(m_hWndListBox, LB_GETTEXTLEN, lIndex, 0)
   If lLen > 0 Then
      sBuf = String$(lLen, 0)
      SendMessageByString m_hWndListBox, LB_GETTEXT, lIndex, sBuf
      iPos = InStr(sBuf, vbTab)
      If iPos > 1 Then
         sBuf = Left$(sBuf, iPos - 1)
      End If
   End If
   tR.Left = tR.Left + 20
   ImageList_Draw m_hIml, lIcon, lhDC, tR.Left + 2, tR.Top, ILD_TRANSPARENT
   lLeft = tR.Left + 20
   LSet tR = rc
   tR.Left = lLeft
   
   If Len(sBuf) > 0 Then
      lBkMode = SetBkMode(lhDC, TRANSPARENT)
      DrawText lhDC, sBuf, -1, tR, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE Or
       DT_END_ELLIPSIS
      SetBkMode lhDC, lBkMode
   End If

End Sub