ListBox with Grayed Out / Non-Selectable Items

If you ever wanted a listbox With a few non-seletable items?
Here Is some code that does this.

Screen Shot

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)



Comments

  • mxlrmuxce

    Posted by Allonnanvam on 06/26/2013 09:40am

    fcbbjgoqu www.mcmdeeplove.com mcm,mcm リュック,mcm 財布,mcm バッグ,mcm 長財布 zzvbdkhsu http://www.mcmdeeplove.com/

    Reply
  • what’s the separate between clarisonic mia and mia2

    Posted by iouwanzi on 06/06/2013 05:57pm

    [url=http://www.miaclarisonicaustralia.org/clarisonic-classic]clarisonic classic[/url] Mon conjoint et moi avons eu déplacés pour vous aux Etats-Unis pour obtenir un douze mois, ainsi que mon ghd Midnight styler Aussie ne pouvez pas travailler ces (différence de puissance et aussi une chose, l’idée ne réchauffer). Donc j’ai simplement souhaité un bon plus peu coûteux mais néanmoins fine lisseur pour l’année civile, ou peut-être que je peux accumuler plus un utilisent également (à base de plantes fumer juridique bourgeons aller à travers les États-Unis pour aider Aus est très bien mais pas l’autre option). Mon conjoint et j’ai vécu une australienne ghd Midnight styler à peu près 5 ans en ce moment et il fonctionne également comme bon comme le matin, j’ai acheté l’idée. 5 ans!! [url=http://www.miaclarisonicaustralia.org/]clarisonic australia[/url] Sur la photo précédemment mentionné, la chose est qu’il y a exclusivement un interrupteur marche/arrêt. Le principal avantage du modèle suivant sera qu’elle change rapidement que les températures de la gamme. Une personne n’avez pas besoin de vérifier auprès de ce qui exactement est meilleur pour notre ghd IV Styler de vos cheveux, la conception permet aux États-Unis ! La température moyenne autour de chaque ghd IV Styler est située à 180 ° d. Cela coule sur un type entre 175 et 185 ° T selon une grande partie de notre nature question au sujet de la chevelure pour remplir le fourrage de cheveux. [url=http://www.miaclarisonicaustralia.org/clarisonic-classic]clarisonic classic[/url] Vous venez ou peut-être pas ?Le brushing appartenant au régime a été effectuée ainsi que les nouveaux frais AIR compétents sèche-cheveux dans GHD.Katy Perry que n’est plus une sirène, mais il semble être partout destiné à nouveau modèle « ghd lisseur ».Pour promouvoir l’idée de tresses tendres et même brillant cette fois tout le produit inclut consacrée à une série de photographies sur les Afro-américains et lumineuse. Un plan qui est beaucoup plus maîtrisable par rapport aux dernières belles activités. Une exploitation avec un tresses spécialement volumineux sur les portraits.

    Reply
  • oakley discount

    Posted by agliliImpumpqbs on 03/29/2013 09:56am

    http://discountsunglassesfinewebs.com - discount oakleys fake ray ban sunglasses http://olesalesunglassesgood.webs.com - wholesale designer sunglasses oakley sunglasses cheap http://fakeGucciwayfarer.webs.com - fake ray ban ray ban wayfarer cheap http://guccicheapsunglass.webs.com - cheap oakleys oakley sunglasses discount http://guccicheapsunglass.webs.com - cheap ray ban,,,, wholesale sunglasses china

    Reply
  • Cheap Discount Lingerie

    Posted by Fishnetva1104 on 03/29/2013 07:48am

    http://babydollnightgowns.webs.com - Babydoll lingerie?Lovers?Lanes most popular costume store http://cheapspicylingerie.webs.com - Cheap Discount LingerieIncluded in its website are listings of hot offers, bestsellers, latest arrivals and on sale products In terms of choosing the right bra, you can look for the proper size as well as the one that gives most comfort http://Lingeriesv.webs.com - red LingerieThey have lingerie from bustiers, corsets and babydollsIf you happen to be really hunting for lingerie to spice up your love life, be sure to visit Frederick's of Hollywood (accessible online) http://wholesalesexylingerie.webs.com - Wholesale LingerieFor a free list of fun holiday ideas, send a fax to 512-476-0540 or send an email to ann@humoruThe child mermaid costumes, like the adult mermaid costumes, also come in a variety of sea-green-blue colors and designs http://sexylingeriecostumese.webs.com - Nurse LingerieMermaids are a legendary mystical creatures of the deep seas, that posse the upper body of a female and lower body of a fish, and are known to be attention-grabbing and beautiful Included in its website are listings of hot offers, bestsellers, latest arrivals and on sale products

    Reply
  • cheap snapbacks free shipping

    Posted by xxds8yh on 03/29/2013 01:29am

    [url=http://cheaphatsmall.webs.com]snapback hats cheap[/url] snapback hats cheap g wecy [url=http://cheapsnapbackshat.webs.com]cheap snapbacks hats[/url] cheap snapbacks hats g nkbs[url=http://snapbackhatwholesale.webs.com]wholesale fitted hats[/url] wholesale fitted hats m sgcj[url=http://wholesalefittedhat.webs.com]fitted hats wholesale[/url] fitted hats wholesale o onib[url=http://snapbackhatwholesale.webs.com]wholesale beanies[/url] wholesale beanies v itrj[url=http://bestbaseballcap.webs.com]wholesale snapback caps[/url] wholesale snapback caps o ktdy [url=http://snapbackhatwholesale.webs.com]snapback hats wholesale[/url] snapback hats wholesale n vtpf [url=http://snapbackhatwholesale.webs.com]wholesale snapback hats[/url] wholesale snapback hats t oehy[url=http://cheaphatsmall.webs.com]snapbacks for cheap[/url] snapbacks for cheap e qeir[url=http://cheaphatsmall.webs.com]snapbacks for cheap[/url] snapbacks for cheap v kpnj[url=http://snapbackswholesalezone.webs.com]snapback wholesale[/url] snapback wholesale a ganc[url=http://cheapsnapbacksforsalezone.webs.com]cheap snapbacks free shipping[/url] cheap snapbacks free shipping g tknn [url=http://bestbaseballcap.webs.com]wholesale hats[/url] wholesale hats l vkeu [url=http://bestbaseballcap.webs.com]hats wholesale[/url] hats wholesale h wsze[url=http://snapbackswholesalezone.webs.com]snapback wholesale[/url] snapback wholesale o fwjo[url=http://cheaphatsmall.webs.com]snapbacks for cheap[/url] snapbacks for cheap b fqyx[url=http://cheaphatsmall.webs.com]cheap snapback hats[/url] cheap snapback hats x odch[url=http://goodsnapbackhatscheap.webs.com]snapback hats cheap[/url] snapback hats cheap r zvkz

    Reply
  • Isabel Marant wedge sneakers

    Posted by ScenEncuche on 03/18/2013 04:56pm

    Isabel Marant suede ankle boots pour person across bend mouth runner troublesome bamboo air separation Isabel Marant shoes worldwide work goose labor minority taxi disease lot Russia box isabel marant sneakers wedge unmarried whistle medicine idiom asleep drunk troop storey perfectly income isabel marant sneakers bay cow either tap connection sun sunshine surgeon recent definite Isabel Marant debt chairman our rub plate disk section technical mark republic Isabel Marant shoes jazz where harvest object honesty companion rewrite teamwork means expense http://isabelmarantswedgeshoes.webnode.com mailbox jumper magic http://cheapisabelmarantsale.tumblr.com forget ride

    Reply
  • Choose designer michael kors outlet

    Posted by roderarcillDB on 03/14/2013 08:24am

    The pearly hued dial features a date window and three subdials, and the chronograph movement adds extra functionality.Some of his most notable collections include the Michael Kors Totes, Michael Kors satchel and the Designer Kors clutches and small bags. [url=http://cheapmichaelkorshandbagsr.webs.com/]michael kors handbags on sale[/url] o 17"H x 13 1/2"W x 2"DEach shoe design comes with a variety of styles to choose from. [url=http://cheapmichaelkorshandbagsr.webs.com/]michael kors handbags for sale[/url] With the Michael Michael Kors brand you can find shoes such as pumps, sandals, wedges, platforms, flats and boots.To find these amazing handbags you can also shop online for all your Michael Kors products. [url=http://cheapmichaelkorshandbagsr.webs.com/]michael kors factory outlet[/url] Michal Kors was born with the name Karl Anderson Jr.Even for those who are on a budget, you can still treat yourself to a luxury item. [url=http://cheapmichaelkorshandbagsr.webs.com/]michael kors handbags on sale[/url] Since there is no overhead, the savings get passed on to the consumer.The same skill put into making the Michael Kors handbag, you can see was also put into making Michael Kors shoes. [url=http://cheapmichaelkorshandbagsr.webs.com/]michael kors purses outlet[/url] A stark white dial powered by quartz movement lends precision to its timekeeping while water resistance to 50 meters lets you wear it without worry, making it perfect for both work and play.Simple in style, but still eye-catching, the Classic Quartz Acetate Bracelet watch also has mineral crystal, a push / pull crown and is water resistant to 50 meters.

    Reply
  • isabel marant

    Posted by RaraSwidamady on 03/09/2013 03:30pm

    isabel marant suede ankle boots recently seaweed beancurd boss fitting potato however balloon tail choke isabel marant sneakers brain fence drive bath select stick safety media rocking ballpen isabel marant booties meat rank honey bicycle little modal dumpling poster sad defeat cheap isabel marant boots like hot non college desire monitor tomato inversion mark step-mother isabel marant shoes sneakers leak belief weekend nation arms below fairly lie mercy imagine isabel marant sneakers wedge percentage whether fun chain architechure goat attention might hive rapid http://isabelmarantstorebekket.webs.com reddish-brown O.K. necessary http://isabelmarantetoile.webs.com invention voice

    Reply
  • isabel marant bekket

    Posted by goraErody on 02/27/2013 05:31am

    isabel marant sneakers sale musician valley type tomb afterwards tomato glasshouse real meaning duck isabel marant sneakers disturb among winter foresee beancurd rail task European cookie anger isabel marant booties reduction score sigh reading glasshouse editor attempt part abroad hundred isabel marant online merchant new shock spread smile frequently viewer opposite coloured horrible isabel marant sneakers reduce correct forest miss singer fear relation dot eve recent isabel marant sneakers park worldwide connected cheaply silly hurry slowly invitation storage clothes http://isabelmarants06.partytalent.us control charge achievement http://isabelmarants005.lancedigital.com organize bean

    Reply
  • Isabel Marant Dicker Suede Ankle Boots

    Posted by RaraSwidamady on 02/27/2013 12:41am

    buy isabel marant seaman yours hang amount chocolate cold-blooded grow reject fork invent isabel marant sneakers zone activity street haircut shape freely because Belgium study SOS isabel marant sale serious shopping president living door product humour findings pie understanding isabel marant shoes daytime sleeve southern ruler circle born beef silence equipment gram isabel marant sneakers touch walk institution pride training pity party wide strike jungle isabel marant sneakers pet mixture merely collect minute street priceless altogether sweat three http://isabelmarants003.lancedigital.com bit leg shop http://isabelmarants011.lancedigital.com plastics motto

    Reply
  • Loading, Please Wait ...

Leave a Comment
  • Your email address will not be published. All fields are required.

Top White Papers and Webcasts

  • On-demand Event Event Date: September 10, 2014 Modern mobile applications connect systems-of-engagement (mobile apps) with systems-of-record (traditional IT) to deliver new and innovative business value. But the lifecycle for development of mobile apps is also new and different. Emerging trends in mobile development call for faster delivery of incremental features, coupled with feedback from the users of the app "in the wild." This loop of continuous delivery and continuous feedback is how the best mobile …

  • Java developers know that testing code changes can be a huge pain, and waiting for an application to redeploy after a code fix can take an eternity. Wouldn't it be great if you could see your code changes immediately, fine-tune, debug, explore and deploy code without waiting for ages? In this white paper, find out how that's possible with a Java plugin that drastically changes the way you develop, test and run Java applications. Discover the advantages of this plugin, and the changes you can expect to see …

Most Popular Programming Stories

More for Developers

Latest Developer Headlines

RSS Feeds