ListBox - Add CheckBoxes

Category: Controls - .Techniques

Date: 03-28-2012

Return to Index


 
'Compiler Comments:
'This code is written to compile in PBWin10. To compile in PBWin9, split pt
'into pt.x and pt.y as arguments wherever the PtInRect() API is used.
 
'Compilable Example:
'====================================================================
' Checkbox list, ownerdrawn - by Borje Hagsten, January 2001.
'--------------------------------------------------------------------
' Shows how use an ownerdrawn ListBox to create a CheckBox list.
' Can be useful in settings dialogs, etc.
'
' Specifications: Mouse click and double-click in the CheckBox
' part toggles an item's on/off status between 1 and 0.
' Selection does not change when a user clicks in CheckBox part,
' to enable checkmark setting without changing current selection.
' SpaceBar toggles checkmark for the currently selected item.
' Else the behavior is the same as in any standard ListBox.
' See the LBproc, where the ListBox is fully controlled.
'
' Public Domain, free to use and customize as you like.
' Code is commented, should be easy to follow.
' And as always, use at own resposibility..  :-)
'
'====================================================================
' Declares
'--------------------------------------------------------------------
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Include "WIN32API.INC"
'---------------------------------
%ID_LISTBOX1  = 130
'---------------------------------
Global oldLBproc AS DWord 'for subclassing, to hold original LB procedure address
'---------------------------------
Declare CallBack Function DlgProc
Declare Function LBproc (ByVal hWnd AS DWord, ByVal wMsg AS DWord, _
   ByVal wParam AS DWord, ByVal lParam As LongAs Long
 
'====================================================================
 
Function PBMain
   '--------------------------------------------------------------------
   ' Program entrance
   '------------------------------------------------------------------
   Local c As Long, hDlg AS DWord
 
   DIALOG NEW 0, "Double-click in list..", , , 120, 100, %WS_CAPTION OR %WS_SYSMENU TO hDlg
 
   '------------------------------------------------------------------
   CONTROL ADD LISTBOX, hDlg, %ID_LISTBOX1, , 5, 5, 110, 80, _
      %WS_CHILD OR %WS_TABSTOP OR %WS_VSCROLL OR %LBS_HASSTRINGS OR _
      %LBS_OWNERDRAWFIXED, %WS_EX_CLIENTEDGE
 
   FOR c = 1 TO 7    'Fill in the items for the ListBox
      LISTBOX ADD hDlg, %ID_LISTBOX1, "Item number " & STR$(c)
   NEXT
   '------------------------------------------------------------------
 
   CONTROL ADD BUTTON, hDlg, %IDOK,     "&Status",  5, 82, 50, 14
   CONTROL ADD BUTTON, hDlg, %IDCANCEL, "&Close",  65, 82, 50, 14
 
   DIALOG SHOW MODAL hDlg, CALL DlgProc
End Function
 
   '====================================================================
 
CallBack Function DlgProc
   '--------------------------------------------------------------------
   ' Main dialog's callback procedure
   '------------------------------------------------------------------
 
   Local c As Long, lRes As Long, ln As Long, txt As String
   STATIC hList AS DWord
 
   SELECT CASE As Long CBMSG
      CASE %WM_INITDIALOG
         ' Get and store ListBox handle in a static variable
         CONTROL HANDLE CBHNDL, %ID_LISTBOX1 TO hList
         'Subclass the ListBox
         oldLBproc = SetWindowLong(hList, %GWL_WNDPROC, CODEPTR(LBproc))
 
      CASE %WM_COMMAND
         SELECT CASE As Long CBCTL
            CASE %IDOK
               IF CBCTLMSG = %BN_CLICKED THEN
                  ' Grab checked status for all items via a FOR/NEXT loop, like:
                  FOR c = 0 TO SendMessage(hList, %LB_GETCOUNT, 0, 0) - 1
                     lRes = SendMessage(hList, %LB_GETITEMDATA, c, 0)
                     txt = txt + "Item" + STR$(c+1) + " = " + STR$(lRes) + $CRLF
                     'can store checked status (lRes) in an array too, or whatever..
                  NEXT
                  MSGBOX txt, _
                     %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL, _
                     "Status for all items"
               END IF
 
            CASE %IDCANCEL 'Close dialog on Escape or Cancel button pressed..
               IF CBCTLMSG = %BN_CLICKED THEN DIALOG END CBHNDL
 
            CASE %ID_LISTBOX1
               SELECT CASE CBCTLMSG
                  CASE %LBN_DBLCLK    'to trap double-click in list
                     '-----------------------------------------------------------
                     ln   = SendMessage(hList, %LB_GETCURSEL, 0, 0)  ' zero-based result..
                     lRes = SendMessage(hList, %LB_GETITEMDATA, ln, 0)
                     LISTBOX GET TEXT CBHNDLCBCTL TO txt
                     txt = "Selected item: " + STR$(ln + 1) + $CRLF + _
                        "Containing text:    " + txt + $CRLF + _
                        "Checked status: " + STR$(lRes)
                     MSGBOX txt, _
                        %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL, _
                        "CheckList message"
                     '-----------------------------------------------------------
 
                  CASE %LBN_SELCHANGE 'to trap changes in selection, if you need..
 
               END SELECT
         END SELECT
 
      CASE %WM_DESTROY 'Un-subclass the listbox on exit
         IF oldLBproc THEN
            SetWindowLong hList, %GWL_WNDPROC, oldLBproc
         END IF
 
      CASE %WM_DRAWITEM 'Pass this message on to LBproc
         IF CBWPARAM = %ID_LISTBOX1 THEN
            Function = LBproc(hList, CBMSGCBWPARAMCBLPARAM)
         END IF
 
   END SELECT
End Function
 
   '====================================================================
 
Function LBproc (ByVal hWnd AS DWord, ByVal wMsg AS DWord, _
      ByVal wParam AS DWord, ByVal lParam As LongAs Long
   '--------------------------------------------------------------------
   ' Subclassed ListBox procedure
   '------------------------------------------------------------------
   Local t As Long, itd As Long, hw As Long, pt AS POINTAPI, rc AS RECT
   Local lpDis AS DRAWITEMSTRUCT PTR, zTxt As AsciiZ * 100
 
   SELECT CASE As Long wMsg
      CASE %WM_DRAWITEM
         lpDis = lParam
         IF @lpDis.itemID = &HFFFFFFFF& THEN EXIT Function
         rc = @lpDis.rcItem
         hw = rc.nBottom - rc.nTop  ' Line height = box height and width
 
         SELECT CASE As Long @lpDis.itemAction
            CASE %ODA_DRAWENTIRE, %ODA_SELECT
               'DRAW BACKGROUND
               IF (@lpDis.itemState AND %ODS_SELECTED) = 0 THEN               'Not selected
                  SetBkColor @lpDis.hDC, GetSysColor(%COLOR_WINDOW)           'Set text Background
                  SetTextColor @lpDis.hDC, GetSysColor(%COLOR_WINDOWTEXT)     'Set text color
                  FillRect @lpDis.hDC, rc, GetSysColorBrush(%COLOR_WINDOW)    'Paint line
               ELSE
                  SetBkColor @lpDis.hDC, GetSysColor(%COLOR_HIGHLIGHT)        'Set text Background
                  SetTextColor @lpDis.hDC, GetSysColor(%COLOR_HIGHLIGHTTEXT)  'Set text color
                  rc.nLeft = hw - 2  ' adjust rect - only use highlight colors in text-part
                  FillRect @lpDis.hDC, rc, GetSysColorBrush(%COLOR_HIGHLIGHT) 'Paint line
               END IF
 
               'DRAW TEXT
               SendMessage hWnd, %LB_GETTEXT, @lpDis.itemID, VARPTR(zTxt)     'Get text
               rc.nLeft = hw  ' adjust left side of rect for DrawText call
               DrawText @lpDis.hDC, zTxt, LEN(zTxt), rc, _
                  %DT_SINGLELINE OR %DT_LEFT OR %DT_VCENTER
 
               'DRAW CHECKBOX
               rc.nLeft   = 2       'Set cordinates for CheckBox drawing
               rc.nRight  = hw - 4
               IF SendMessage(hWnd, %LB_GETITEMDATA, @lpDis.itemID, 0) THEN 'draw checked or not?
                  DrawFrameControl @lpDis.hDC, rc, %DFC_BUTTON, _
                     %DFCS_BUTTONCHECK OR %DFCS_CHECKED OR %DFCS_FLAT
               ELSE
                  DrawFrameControl @lpDis.hDC, rc, %DFC_BUTTON, _
                     %DFCS_BUTTONCHECK OR %DFCS_FLAT
               END IF
               Function = %TRUE : EXIT Function 'return %TRUE and exit
 
            CASE %ODA_FOCUS
               @lpDis.rcItem.nLeft = hw - 2
               DrawFocusRect @lpDis.hDC, @lpDis.rcItem  'draw focus rectangle if in focus
               Function = %TRUE : EXIT Function 'return %TRUE and exit
 
         END SELECT
 
      CASE %WM_KEYDOWN
         IF wParam = %VK_SPACE THEN                             'Respond to space bar
            t = SendMessage(hWnd, %LB_GETCURSEL, 0, 0)          'get selected
            itd = 1 - SendMessage(hWnd, %LB_GETITEMDATA, t, 0)  'toggle item data 0/1
            SendMessage hWnd, %LB_SETITEMDATA, t, itd           'set toggleded item data
            SendMessage hWnd, %LB_GETITEMRECT, t, VARPTR(rc)    'get selected item's rect
            InvalidateRect hWnd, rc, 0 : UpdateWindow hWnd      'update sel. item only
            Function = 0 : EXIT Function                        'return zero
         END IF
 
      CASE %WM_KEYUP
         IF wParam = %VK_RETURN THEN ' If to act on the Enter key..
            ' do whatever..
         END IF
 
      CASE %WM_LBUTTONDOWN, %WM_LBUTTONDBLCLK
         IF wParam = %MK_LBUTTON  THEN                              'respond to mouse clicks
            pt.x = LOWRD(lParam) : pt.y = HIWRD(lParam)            'get cursor pos
            t = SendMessage(hWnd, %LB_ITEMFROMPOINT, 0, MAKLNG(pt.x, pt.y)) 'get sel. item
            SendMessage hWnd, %LB_GETITEMRECT, t, ByVal VARPTR(rc) 'get sel. item's rect
            rc.nLeft  = 2                                          'checkbox coordinates
            rc.nRight = rc.nBottom - rc.nTop - 4                   '(see %WM_DRAWITEM above)
            IF PtInRect(rc, pt) THEN                       'if in CheckBox area
               itd = 1 - SendMessage(hWnd, %LB_GETITEMDATA, t, 0) 'toggle item data 0/1
               SendMessage hWnd, %LB_SETITEMDATA, t, itd          'set toggled item data
               InvalidateRect hWnd, rc, 0 : UpdateWindow hWnd     'update sel. item only
               Function = 0 : EXIT Function                       'return zero, to avoid selection change
            END IF
         END IF
 
      CASE %WM_MOUSEMOVE
         IF wParam <> %MK_LBUTTON THEN
            EXIT Function  'exit and return zero, to avoid selection change
         END IF
 
   END SELECT
 
   Function = CallWindowProc(oldLBproc, hWnd, wMsg, wParamlParam'process other messages
 
End Function
 
'gbs_00794
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm