ListBox with Grayed Out / Non-Selectable Items

This Is still under development.. Only Ver 1.0 Is ready. More To come..

To test this: Take a test project. Add a module And a form. Copy the following code And run.

SAVE before RUNNING, please..

In this test, i am rejecting selection of every 3rd Item. This Is based On index. Another way would be To reject based On Listitem (String): The usual technique Is To have a String starting With "!*...." Or something Like that, And look For that identification In the selected Item. I will Put that also up In near future ( i.e when ever i Get Time:-) )

Any suggestions most welcome.

Ravi Kiran

Put this code In a module (mLBSbCls.Bas)

' Listbox Subclassing: Ported the C code found
' on MSDN at
'      SDK Documentation/PlatformSDK/User
'      Interace services/controls/listbox
' and Knowledgebase Article ID: Q74792
'
' By T. Ravi Kiran.
' E-Mail: t_ravi_kiran@rocketmail.com
' You can also send me messages at CodeGuru site: /vb
'
'
' List box sub classing: to achieve Non-selectable items
' in a ListView
'
' What This piece of code does:
'   1. Display some predefined ListItems in Gray
'      (inactive) color.
'   2. Disallow user selection of these items by
'      mouse (click)
'   3. When scrolled/browsed by Arrow keys, jump over
'      these non-active items
'
'
' How to Use:
'   step 1: Take a form and put a list box.
'   step 2: set the Listbox and Parent control's pointers
'           of this module to them
'   step 3: Call SetHooks to setup the subclass
'           procedures.
'   step 4: Run.
'   step 5: REMEMBER to unhook by callikg UnSetHooks
'           in the end.
'
' Notes: You will find a lot of commented out code.
' That is because i am
' planning for future upgrades
'
' Advice: If you are debugging this code, DONT put break
' points in subclassed Window procedures.
' VB IDE could become unstable. Always use
' Debug.print to print any variable's value.
' Save before running, PLEASE..
'
option Explicit

'
' Win API Rect structure
'
private Type RECT
    Left as Long
    Top as Long
    Right as Long
    Bottom as Long
End Type
' The Draw item structure for Owener Draw items of
' basic control types
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
'
' Owner draw control types
'
'Const ODT_MENU = 1
Const ODT_LISTBOX = 2
'Const ODT_COMBOBOX = 3
'Const ODT_BUTTON = 4
'Const ODT_STATIC = 5

' Standard windows style
Const WS_VSCROLL = &H200000
Const WS_HSCROLL = &H100000
Const WS_BORDER = &H800000

public Const GWL_STYLE = (-16)
public Const GWL_EXSTYLE = (-20)

' List Box Styles:
'public Const LBS_NOTIFY = &H1
'public Const LBS_SORT = &H2
'public Const LBS_NOREDRAW = &H4
public Const LBS_MULTIPLESEL = &H8
public Const LBS_OWNERDRAWFIXED = &H10
'public Const LBS_OWNERDRAWVARIABLE = &H20
'public Const LBS_HASSTRINGS = &H40
'public Const LBS_USETABSTOPS = &H80
'public Const LBS_NOINTEGRALHEIGHT = &H100
'public Const LBS_MULTICOLUMN = &H200
'public Const LBS_WANTKEYBOARDINPUT = &H400
'public Const LBS_EXTENDEDSEL = &H800
'public Const LBS_DISABLENOSCROLL = &H1000
'public Const LBS_NODATA = &H2000
'public Const LBS_NOSEL = &H4000
'public Const LBS_STANDARD = (LBS_NOTIFY Or LBS_SORT
'Or WS_VSCROLL Or WS_BORDER)

'List box Notification messages:
Const LBN_SELCHANGE = 1
Const LBN_DBLCLK = 2
Const LBN_SELCANCEL = 3
Const LBN_SETFOCUS = 4
Const LBN_KILLFOCUS = 5

' List box Messages: This is the complete set.
' In this example only few are used.
'Const LB_ADDSTRING = &H180
'Const LB_INSERTSTRING = &H181
'Const LB_DELETESTRING = &H182
'Const LB_SELITEMRANGEEX = &H183
'Const LB_RESETCONTENT = &H184
'Const LB_SETSEL = &H185
Const LB_SETCURSEL = &H186
'Const LB_GETSEL = &H187
Const LB_GETCURSEL = &H188
Const LB_GETTEXT = &H189
Const LB_GETTEXTLEN = &H18A
'Const LB_GETCOUNT = &H18B
'Const LB_SELECTSTRING = &H18C
'Const LB_DIR = &H18D
'Const LB_GETTOPINDEX = &H18E
'Const LB_FINDSTRING = &H18F
'Const LB_GETSELCOUNT = &H190
'Const LB_GETSELITEMS = &H191
'Const LB_SETTABSTOPS = &H192
'Const LB_GETHORIZONTALEXTENT = &H193
'Const LB_SETHORIZONTALEXTENT = &H194
'Const LB_SETCOLUMNWIDTH = &H195
'Const LB_ADDFILE = &H196
'Const LB_SETTOPINDEX = &H197
'Const LB_GETITEMRECT = &H198
'Const LB_GETITEMDATA = &H199
'Const LB_SETITEMDATA = &H19A
'Const LB_SELITEMRANGE = &H19B
'Const LB_SETANCHORINDEX = &H19C
'Const LB_GETANCHORINDEX = &H19D
Const LB_SETCARETINDEX = &H19E
Const LB_GETCARETINDEX = &H19F
'Const LB_SETITEMHEIGHT = &H1A0
'Const LB_GETITEMHEIGHT = &H1A1
'Const LB_FINDSTRINGEXACT = &H1A2
'Const LB_SETLOCALE = &H1A5
'Const LB_GETLOCALE = &H1A6
'Const LB_SETCOUNT = &H1A7
'Const LB_INITSTORAGE = &H1A8
Const LB_ITEMFROMPOINT = &H1A9
'Const LB_MSGMAX = &H1B0


' The Windows Standard colors constants:-
' to be used with GetSysColor call
Const COLOR_WINDOW = 5
Const COLOR_WINDOWTEXT = 8
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_GRAYTEXT = 17


'
' Notify Message
'
private Const WM_NOTIFY& = &H4E
public Const WM_COMMAND = &H111
Const WM_DRAWITEM = &H2B

' Mouse Constants:-
'Const WM_MOUSEFIRST = &H200
Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
'Const WM_LBUTTONUP = &H202
Const WM_LBUTTONDBLCLK = &H203
'Const WM_RBUTTONDOWN = &H204
'Const WM_RBUTTONUP = &H205
'Const WM_RBUTTONDBLCLK = &H206
'Const WM_MBUTTONDOWN = &H207
'Const WM_MBUTTONUP = &H208
'Const WM_MBUTTONDBLCLK = &H209

' Windows messages related to keyboard:
Const WM_KEYDOWN = &H100
Const WM_CHAR = &H102

Const WM_GETFONT = &H31
Const WM_PAINT = &HF
Const WM_ERASEBKGND = &H14


' ** Constants relating to the selected status of
' ** list item:
Const ODA_FOCUS = &H4       ' This is for the
                            ' List box of Combo box!
Const ODS_FOCUS = &H10
Const ODS_SELECTED = &H1

'
' Win API Declarations
'
private Declare Sub CopyMemory Lib _
    "kernel32" Alias "RtlMoveMemory" _
    (pDest as Any, pSource as Any, _
    byval dwLength as Long)
public Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (byval hwnd as Long, _
    byval wMsg as Long, byval _
    wParam as Long, lParam as Any) _
    as Long

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
'Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA"
'(byval hdc as Long, byval lpsz as string, byval n as Long,
'lpRect as RECT, byval un as Long, _
'lpDrawTextParams as DRAWTEXTPARAMS) as Long
Declare Function SetTextAlign Lib "gdi32" (byval _
    hdc as Long, byval _
    wFlags as Long) as Long
Declare Function SetTextColor Lib "gdi32" (byval hdc as Long, _
    byval crColor as Long) as Long
Declare Function SetBkColor Lib "gdi32" (byval hdc as Long, _
    byval crColor as Long) as Long
Declare Function InvalidateRect Lib "user32" (byval hwnd as Long, _
     lpRect as RECT, byval bErase as Long) as Long
Declare Function BitBlt Lib "gdi32" (byval hDestDC as Long, _
    byval X as Long, _
    byval Y as Long, _
    byval nWidth as Long, _
    byval nHeight as Long, _
    byval hSrcDC as Long, _
    byval xSrc as Long, _
    byval ySrc as Long, _
    byval dwRop as Long) as Long

Declare Function DrawFocusRect Lib "user32" (byval hdc as Long, _
     lpRect as RECT) as Long
Declare Function CreateSolidBrush Lib "gdi32" _
    (byval crColor as Long) as Long
Declare Function GrayString Lib "user32" Alias "GrayStringA" _
    (byval hdc as Long, _
    byval hBrush as Long, _
    byval lpOutputFunc as Long, _
        byval lpData as string, _
        byval nCount as Long, _
        byval X as Long, _
        byval Y as Long, _
        byval nWidth as Long, _
        byval nHeight as Long) _
        as Long
'Declare Function GrayString Lib "user32"
'Alias "GrayStringA" (byval hdc as Long,
'byval hBrush as Long, byval lpOutputFunc as Long,
        byval lpData as Long, _
        byval nCount as Long, _
        byval x as Long, _
        byval y as Long, _
        byval nWidth as Long, _
        byval nHeight as Long) _
        as Long
Declare Function DeleteObject Lib "gdi32" _
    (byval hObject as Long) as Long
Declare Function GetSysColor Lib "user32" _
    (byval nIndex as Long) as Long
Declare Function FillRect Lib "user32" (byval hdc as Long, _
    lpRect as RECT, byval hBrush as Long) as Long
Declare Function TextOut Lib "gdi32" _
    Alias "TextOutA" (byval hdc as Long, _
    byval X as Long, _
    byval Y as Long, _
    byval lpString as string, _
    byval nCount as Long) _
    as Long
' I couldn't get the SendMessage(LB_GETTEXT) to work with VB's
' string variable. So i modified the definition to handle
' byte-arrays for both SendMessage and TextOut API calls.
' So if you are using this with in similar
' definitions please take note of.
' This defn works with both Eng & Japanese strings.
' So i guess it is ok.
Declare Function TextOutBStr Lib "gdi32" Alias "TextOutA" _
    (byval hdc as Long, _
    byval X as Long, _
    byval Y as Long, _
    lpString as Any, _
    byval nCount as Long) as Long


public Const GW_OWNER = 4
public Const GWL_WNDPROC = (-4)
public Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" (byval hwnd as Long, _
    byval nIndex as Long) as Long
Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" _
    (byval hwnd as Long, _
    byval nIndex as Long, _
    byval dwNewLong as Long)_
     as Long
Declare Function CallWindowProc Lib "user32" _
    Alias "CallWindowProcA" _
    (byval lpPrevWndFunc as Long, _
    byval hwnd as Long, _
    byval Msg as Long, _
    byval wParam as Long, _
    byval lParam as Long) _
    as Long



'' This module related constants
Const TwoPower16 = 2 ^ 16       '!!. I need this for
                                'lparam to/from conv.

private lpListBox as ListBox
private lpParent as Form     '<-- Change this in case
                             ' the parent is not Form
            ' Any VB container control will do.
            ' Ex Frame, Picturebox, Form

public lpHBitmap(3) as StdPicture ' for the 3 states
                                  ' of Multi-selection LB item

public oldWndProc as Long

private LBProc1 as Long
private m_Hooked_LBhWnd as Long
private m_LBHwnd as Long
private m_Hooked_hWnd as Long
private m_bCustomDraw _as Boolean

public Function SetListBox(lpLB as ListBox)_
     as Boolean
    on error GoTo errset
    set lpListBox = lpLB
    m_LBHwnd = lpListBox.hwnd
    SetListBox = true
    Exit Function
errset:
End Function
public Function SetLBParent(lpLBBoss as Form) _
    as Boolean
    on error GoTo errset
    set lpParent = lpLBBoss
    SetLBParent = true
    Exit Function
errset:
End Function


' This is for subclassing the parent, so that we can
' listen to list box's Notification messages
private Function LBSubcls_WndProc_V3(byval hwnd as Long, _
    byval Msg as Long, _
    byval wParam as Long, _
    byval lParam as Long) _
    as Long
    Dim iHw as Integer, iLW as Integer
    Dim lCurind as Long
    Select Case Msg
        Case WM_COMMAND
            If lParam = m_LBHwnd then
                LongInt2Int wParam, iHw, iLW
                Select Case (iHw)
                Case LBN_SELCHANGE
'                    lCurind = SendMessage(lParam,
'                    LB_GETCURSEL, 0, byval 0&)
'                    Debug.print " LBN selchange
'                    with for"; Hex$(lCurind)
'                    'If IndexAllowed(lCurind) = false
'                    'then
'                    ' You might need a fn like above:
'                    ' for my case
'                    If (lCurind Mod 3) = 0 then
'                    lCurind = SendMessage(lParam,
'                    LB_SETCURSEL, lCurind + 1, byval 0&)
'                    End If
                    'Debug.print " sendmessage returned:";
                    'Hex$(lCurind)
                Case LBN_SELCANCEL
                    lCurind = SendMessage(lParam, LB_GETCURSEL, _
                        0, byval 0&)
                    Debug.print " lbnselcancel for:"; _
                       Hex$(lCurind)
                Case LBN_DBLCLK
                'Case LBN_KILLFOCUS
                'Case LBN_SETFOCUS
                End Select
            End If
        Case WM_DRAWITEM
            If LB_Drawitem(lParam) = 0 then
                ' we have handled the painting. So don't pass
                ' on to default window procedure
                LBSubcls_WndProc_V3 = 0
                Exit Function
            End If
        Case else
    End Select
    '
    ' ** for other things do default behaviour:
    '
    LBSubcls_WndProc_V3 = CallWindowProc(oldWndProc, hwnd, Msg, _
                                         wParam, lParam)

End Function

public Sub SetHooks()
    If lpListBox is nothing then
        MsgBox "List box pointer Not set. _
                     Wrong sequence of calls"
        Exit Sub
    End If
    If lpParent is nothing then
        MsgBox "parent pointer for the LB Not set. _
                     Wrong sequence of calls"
        Exit Sub
    End If
    SetHookLB lpListBox.hwnd, true
    SetHookParent lpParent.hwnd, true
End Sub
public Sub UnSetHooks()
    SetHookLB vbNull, false
    SetHookParent vbNull, false
End Sub

public Sub SetHookParent(byval hwnd as Long, _
    b as Boolean)
    If b then
        oldWndProc = SetWindowLong(hwnd, GWL_WNDPROC, _
                                   AddressOf LBSubcls_WndProc_V3)
        m_Hooked_hWnd = hwnd
        m_bCustomDraw = true
    else
        Call SetWindowLong(m_Hooked_hWnd, GWL_WNDPROC, oldWndProc)
        m_Hooked_hWnd = 0
    End If
End Sub

public Sub SetHookLB(byval LBhWnd as Long, _
    b as Boolean)
    If b then
        LBProc1 = SetWindowLong(LBhWnd, GWL_WNDPROC, _
AddressOf LBSubcls_WndProc_V4)
        m_Hooked_LBhWnd = LBhWnd
    else
        Call SetWindowLong(m_Hooked_LBhWnd, GWL_WNDPROC, LBProc1)
        m_Hooked_LBhWnd = 0
    End If
End Sub
    
' Item Draw Notification Event handler for List Box:
private Function LB_Drawitem(byval _
    lParam as Long) as Integer
    ' The input is actually a pointer to a structure
    ' of type DrawItemStruct
    Dim drawstruct as DRAWITEMSTRUCT
    Dim szBuf(256) as Byte
    ' The 'C's way of pointer casting has to implemented
    ' in VB by copying.
    CopyMemory drawstruct, byval lParam, len(drawstruct)

    ' Let's not allow every 3rd item to be selected.
    Dim i as Integer
    Dim hbrGray as Long, hbrback as Long, _
    szListStr as string ' * 256
    Dim crback as Long, crtext as Long, lbuflen as Long
    Select Case (drawstruct.CtlType)
    Case ODT_LISTBOX:
        ' get the string:
        lbuflen = SendMessage(drawstruct.hwndItem, _
                          LB_GETTEXTLEN, _
                          drawstruct.itemID, byval 0&)
        ' ideally you should redim : Redim szBuf(lbuflen+2)
        '
        ' I couldn't get the SendMessage(LB_GETTEXT) to work
        ' with VB's string variable. So I
        ' modified the definition to handle
        ' byte-arrays for both SendMessage
        ' and TextOut API calls - see defs section on top.
        lbuflen = SendMessage(drawstruct.hwndItem, _
                          LB_GETTEXT, _
                          drawstruct.itemID, szBuf(0))
        
        i = drawstruct.itemID
        '' ** Change this condition to suit
        '' ** your requirement***
        '' Only Ex: Every 3rd element is not allowed.
        If i Mod 3 = 0 then
'            hbrGray = CreateSolidBrush(GetSysColor
'            (COLOR_GRAYTEXT))
'            GrayString drawstruct.hdc, hbrGray,
'            byval 0&, szListStr,
'            len(szListStr), _
'                      drawstruct.rcItem.Left,
'                      drawstruct.rcItem.Top, _
'                      0, 0
'            DeleteObject hbrGray
            crback = RGB(180, 180, 180)
            crtext = RGB(60, 60, 60)
        else
            If (drawstruct.itemState And ODS_SELECTED) = _
               ODS_SELECTED then
                '/* set background and text colors
                '/* for selected item */
                crback = GetSysColor(COLOR_HIGHLIGHT)
                crtext = GetSysColor(COLOR_HIGHLIGHTTEXT)
                ' Or you could use other colors and be
                ' un-Windows like!
                'crback = vbGreen
                'crtext = vbWhite
            ElseIf (drawstruct.itemState And ODS_FOCUS) = _
                ODS_FOCUS then
                ' for Multi selection listbox, this state
                ' exists - Current focus
                ' choose a seperate color if we want!
                crback = GetSysColor(COLOR_WINDOW)
                crtext = vbRed
            else
                '/* set background and text colors for
                '/* unselected item */
                ' Default windows colors:-
                'crback = GetSysColor(COLOR_WINDOW)
                'crtext = GetSysColor(COLOR_WINDOWTEXT)
                ' Some colors:-
                'crback = vbBlue
                'crtext = vbCyan
                'Since VB supports Design time setting
                'of colors:
                crback = lpListBox.BackColor
                crtext = lpListBox.ForeColor
            End If
            ' Some un-Windows effects:-
            If (drawstruct.itemState And ODS_FOCUS) = _
                ODS_FOCUS then
                crtext = vbRed
            End If
        End If
        '// Fill item rectangle with background color
        hbrback = CreateSolidBrush(crback)
        FillRect drawstruct.hdc, drawstruct.rcItem, hbrback
        DeleteObject hbrback

        '// set current background and text colors
        SetBkColor drawstruct.hdc, crback
        SetTextColor drawstruct.hdc, crtext

        '// TextOut uses current background and text colors
'            TextOut drawstruct.hdc, _
'                      drawstruct.rcItem.Left, _
'                      drawstruct.rcItem.Top, _
'                      szListStr, len(szListStr)
        TextOutBStr drawstruct.hdc, _
                  drawstruct.rcItem.Left, _
                  drawstruct.rcItem.Top, _
                   szBuf(0), lbuflen
        '/* If enabled item has the input focus, call
        'DrawFocusRect to set or clear the focus
        'rectangle */
        If (drawstruct.itemState And ODS_FOCUS) then
            DrawFocusRect drawstruct.hdc, drawstruct.rcItem
        End If
            
        ' If we handled the painting we will pass 0, else 1
        LB_Drawitem = 0
''''    ' Other Possible cases:-
''''    Case ODT_COMBOBOX:
''''    Case ODT_BUTTON
''''    Case ODT_MENU
''''    Case ODT_STATIC
        Case else ' IMPORTANT!- We are not handling other guys!
            LB_Drawitem = 1
    End Select
End Function

' This function is damm performance hit. Please tell me
' if you can find a better one to get the higher word
' from longword
public Function LongInt2Int(byval lLongInt as Long, _
    byref iHiWord as Integer, byref iLowWord as Integer) _
        as Boolean
    Dim tmpHW as Integer, tmpLW as Integer
    CopyMemory tmpLW, lLongInt, len(tmpLW)
    tmpHW = (lLongInt / TwoPower16)
    iHiWord = tmpHW
    iLowWord = tmpLW
End Function
public Function MakeLParam(byval iHiWord as Integer, _
    byval iLowWord as Integer) as Long
    MakeLParam = (iHiWord * TwoPower16) + iLowWord
End Function

' This is to sub class the List box itself
' Process Mouse click & DBL click on items and
' reject clicks on not allowed ones
' Process key down messages and jump over not
' allowed ones.

private Function LBSubcls_WndProc_V4(byval hwnd as Long, _
    byval Msg as Long, _
    byval wParam as Long, _
    byval lParam as Long) _
    as Long
    Dim iHw as Integer, iLW as Integer
    Dim lCurind as Long
    Select Case Msg
        Case WM_LBUTTONDOWN, WM_LBUTTONDBLCLK
            LongInt2Int lParam, iHw, iLW
            Debug.print " Mouse down at("; iHw; ","; iLW; ")";
            lCurind = SendMessage(hwnd, LB_ITEMFROMPOINT, _
            byval 0, byval lParam)
            Debug.print "Index of btn down:"; Hex$(lCurind)
            If (lCurind Mod 3) = 0 then
                LBSubcls_WndProc_V4 = 1
                ' by doing this we will be eating away the
                ' click on unwanted items.
                Exit Function
            End If
        Case WM_KEYDOWN
            LongInt2Int wParam, iHw, iLW
            Select Case (iLW)
            Case vbKeyDown
                lCurind = SendMessage(hwnd, LB_GETCARETINDEX, 0, _
                          byval 0&)
                Debug.print " Keydown With Itemid :"; _
                    Hex$(lCurind)
                If ((lCurind + 1) Mod 3) = 0 then
                    lCurind = SendMessage(hwnd, LB_SETCARETINDEX, _
                              lCurind + 1, byval 0&)
                End If
                lCurind = SendMessage(hwnd, LB_GETCURSEL, 0, _
                                      byval 0&)
                Debug.print " Keydown With Itemid :"; _
                    Hex$(lCurind)
                If ((lCurind + 1) Mod 3) = 0 then
                    lCurind = SendMessage(hwnd, LB_SETCURSEL, _
                                          lCurind + 1, byval 0&)
                End If
                ' Notice that we are still letting the
                ' Focus rect be drawn by default window
                ' proc. We are just changing the Caret
                ' item /focus item.
            Case vbKeyUp
                lCurind = SendMessage(hwnd, LB_GETCARETINDEX, _
                                      0, byval 0&)
                Debug.print " KeyUp With Itemid :"; _
                    Hex$(lCurind)
                If ((lCurind - 1) Mod 3) = 0 then
                    lCurind = SendMessage(hwnd, LB_SETCARETINDEX, _
                                          lCurind - 1, byval 0&)
                End If
                lCurind = SendMessage(hwnd, LB_GETCURSEL, 0, byval 0&)
                Debug.print " KeyUp With Itemid :"; Hex$(lCurind)
                If ((lCurind - 1) Mod 3) = 0 then
                    lCurind = SendMessage(hwnd, LB_SETCURSEL, lCurind - 1, byval 0&)
                End If
            ' These two are also to be handled:-
            Case vbKeyPageUp
            Case vbKeyPageDown
            End Select
        Case else
    End Select
    '
    ' ********* as OF NOW WE ARE ONLY DOING DEFAULT
    ' BEHAVIOUR *********
    '
    LBSubcls_WndProc_V4 = CallWindowProc(LBProc1, hwnd, Msg, _
                                         wParam, lParam)

End Function

For testing take a form.

In it Put a list box , 2 check boxes , 2 Command btns , a label And a Timer. All default names.

Set the Listbox Style Property To 1, To see all effects. This has To be Set In Design mode. It Is readonly at run Time.

Copy the following code.

option Explicit
private m_hooked as Boolean
private Sub Check1_Click()
    With Check1
    If .Value = 1 then
         mLBSbCls.SetListBox List1
        ' set the hook procedure
        SetHookParent me.hwnd, true
        m_hooked = true
        
        .Caption = "UnSet the Listbox Notification Hook _
                    ( from Form)"
    
    else
        SetHookParent me.hwnd, false
        m_hooked = false
        .Caption = "Subclass Parent form _
                    ( Gives Gray shading items)"
    End If
    End With

End Sub

private Sub Check2_Click()
    If Check2.Value = 1 then
        SetHookLB List1.hwnd, true
        Check2.Caption = " Unhook listbox : Remove _
                          subclass procedure"
    else
        SetHookLB List1.hwnd, false
        Check2.Caption = " Hook (subclass) list _
                          box - Process && Remove click on Gray items"
    End If
End Sub


private Sub Command1_Click()
    Dim i
    List1.Clear
    for i = 0 to 10
        List1.AddItem "Item - " & Str(i)
    next i
End Sub

private Sub Command2_Click()
    Dim i as Integer
    for i = 0 to 2
        With List1
            .AddItem "Item - " & Str(.ListCount)
        End With
    next i
End Sub

private Sub Form_Activate()
    Debug.print " Form Hwnd=" & Hex$(me.hwnd);
    Debug.print " List hwnd=" & Hex$(List1.hwnd);
    Debug.print " Check1 hwnd=" & Hex$(Check1.hwnd);
    Debug.print " Command1 hwnd=" & Hex$(Command1.hwnd)
    
    Dim lrtn as Long
    lrtn = GetWindowLong(List1.hwnd, GWL_STYLE)
    Debug.print "List box Style:0x" & Hex$(lrtn)
    If (lrtn And LBS_OWNERDRAWFIXED) = _
        LBS_OWNERDRAWFIXED then
        Debug.print "List box style: OwnerDraw Fixed"
    End If
    If (lrtn And LBS_MULTIPLESEL) = LBS_MULTIPLESEL then
        Debug.print "List box style: Multiple selection"
        lrtn = lrtn Xor LBS_MULTIPLESEL
    End If
    Debug.print "Setting window style: 0x" & Hex$(lrtn)
    lrtn = SetWindowLong(List1.hwnd, GWL_STYLE, lrtn)
    Debug.print "Setwindow rtn value : 0x" & Hex$(lrtn)
    
End Sub

private Sub Form_Load()
    
    If App.PrevInstance = true then
        MsgBox "There is an instance already running.
                Can't run one more"
        Unload me
    else
        Command1_Click
    End If
    ' These 2 lines give more GUI effect
    Check2.Value = 1
    Check1.Value = 1
    
    ' If you uncomment the following lines of code,
    ' then do the same in Form_Unload also
    'Straight forward calling also works
    'mLBSbCls.SetListBox List1
    'mLBSbCls.SetLBParent me
    'mLBSbCls.SetHooks
End Sub

private Sub Form_MouseMove(Button as Integer, _
    Shift as Integer, X as Single, Y as Single)
    Call Timer1_Timer
End Sub

private Sub Form_Unload(Cancel as Integer)
    If Check2.Value = 1 then
        SetHookLB List1.hwnd, false
    End If
    If m_hooked then
        SetHookParent me.hwnd, false
    End If
    'mLBSbCls.UnSetHooks
End Sub

private Sub List1_MouseMove(Button as Integer, _
    Shift as Integer, X as Single, _
    Y as Single)
    Call Timer1_Timer
End Sub

private Sub Timer1_Timer()
    Label1.Caption = "List Index=" & Str(List1.ListIndex)
End Sub

Download Zipped Project File (16k)