WEBINAR: On-demand webcast
How to Boost Database Development Productivity on Linux, Docker, and Kubernetes with Microsoft SQL Server 2017 REGISTER >
Here Is some code that does this.
This Is still under development.. Only Ver 1.0 Is ready. More To come..
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.
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: email@example.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