Date: 02-16-2022
Return to Index
created by gbSnippets
'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: (Jose Includes)
'====================================================================
' 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 Long) As 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 CBHNDL, CBCTL 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, CBMSG, CBWPARAM, CBLPARAM)
END IF
END SELECT
End Function
'====================================================================
Function LBproc (ByVal hWnd AS DWord, ByVal wMsg AS DWord, _
ByVal wParam AS DWord, ByVal lParam As Long) As 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, wParam, lParam) 'process other messages
End Function
'gbs_00794
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm