Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' ListBox Color list, ownerdrawn - by Borje Hagsten, January 2001. '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Someone asked, so here is a quick one. Almost same as the Combobox ' posted earlier - but using listbox instead. Good base for filelist, ' directory list or Checkbox list, etc. ' ' Thanks to: Chris Boss, for the original GetQBColor function. ' Public Domain, feel free to use and customize as you like. ' Code is commented, should be easy to follow. GDI stuff should be ' safe, no leaks. Still, as always, use at own "risk".. :-) '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Declares '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ #COMPILE EXE #INCLUDE "WIN32API.INC" %ID_LABEL1 = 100 %ID_LIST1 = 130 GLOBAL oldLBproc AS LONG 'for subclassing, to hold original window procedure address DECLARE CALLBACK FUNCTION DlgProc DECLARE FUNCTION GetQBColor(BYVAL c AS LONG) AS LONG DECLARE FUNCTION LBproc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Main dialog callback '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ CALLBACK FUNCTION DlgProc SELECT CASE CBMSG CASE %WM_COMMAND SELECT CASE CBCTL CASE %IDOK : DIALOG END CBHNDL 'Exit CASE %ID_LIST1 'IF HIWRD(CBWPARAM) = %LBN_SELCHANGE THEN 'You can trap changes in selection here, if needed. Uncomment 'the following code to see a way of picking selected color. 'Can also be used in other place, like checking before exit, etc. 'LOCAL col AS LONG 'returns selected color 'col = GetQBColor(SendMessage(CBLPARAM, %LB_GETCURSEL, 0, 0)) 'MSGBOX "&H" + HEX$(col) 'FUNCTION = 0: EXIT FUNCTION 'END IF END SELECT CASE %WM_DESTROY 'Un-subclass listbox SetWindowLong GetDlgItem(CBHNDL, %ID_LIST1), %GWL_WNDPROC, oldLBproc CASE %WM_DRAWITEM, %WM_MEASUREITEM 'Pass these on to LBproc IF CBWPARAM = %ID_LIST1 THEN LBproc GetDlgItem(CBHNDL, %ID_LIST1), CBMSG, CBWPARAM, CBLPARAM FUNCTION = 0: EXIT FUNCTION END IF FUNCTION = 0: EXIT FUNCTION END SELECT END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Subclassed Listbox procedures '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION LBproc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG SELECT CASE wMsg CASE %WM_DRAWITEM LOCAL hBrush AS LONG, hBrushOld AS LONG, rct AS RECT LOCAL lpdis AS DRAWITEMSTRUCT PTR, zTxt AS ASCIIZ * 64 lpdis = lParam IF @lpdis.itemID = -1 THEN EXIT FUNCTION SELECT CASE @lpdis.itemAction CASE %ODA_DRAWENTIRE, %ODA_SELECT 'CLEAR BACKGROUND hBrush = CreateSolidBrush(GetSysColor(%COLOR_WINDOW)) 'Create a background brush hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context CALL FillRect(@lpdis.hDC, @lpdis.rcItem, hBrush) 'Paint background color rectangle CALL SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back CALL DeleteObject(hBrush) 'Delete brush 'DRAW TEXT CALL SetBkColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOW)) 'Set text Background CALL SetTextColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOWTEXT)) 'Set text color CALL SendMessage(hWnd, %LB_GETTEXT, @lpdis.itemID, VARPTR(zTxt)) 'Get text CALL TextOut(@lpdis.hDC, 28, @lpdis.rcItem.ntop + 2, zTxt, LEN(zTxt)) 'Draw text 'SELECTED ITEM IF (@lpdis.itemState AND %ODS_SELECTED) THEN 'if selected rct.nLeft = 26 : rct.nRight = @lpdis.rcItem.nRight 'Set cordinates rct.ntop = @lpdis.rcItem.ntop rct.nbottom = @lpdis.rcItem.nbottom CALL InvertRect(@lpdis.hDC, rct) 'invert area around text only END IF 'PAINT COLOR RECTANGLE (using RoundRect for nicer looks.. :-) ' Here you can customize if you like - like BitBlt bitmaps via a memDC ' instead, or use DrawFrameControl to draw a "fake" checkbox, etc.. rct.nLeft = 3 : rct.nRight = 24 'Set cordinates rct.ntop = @lpdis.rcItem.ntop + 2 rct.nbottom = @lpdis.rcItem.nbottom - 2 hBrush = CreateSolidBrush(GetQBColor(@lpdis.itemID)) 'Create brush with proper color hBrushOld = SelectObject(@lpdis.hDC, hBrush) 'Select brush into device context CALL RoundRect(@lpdis.hDC, rct.nLeft, rct.ntop, rct.nRight, rct.nbottom, 3, 3) 'Draw CALL SelectObject(@lpdis.hDC, hBrushOld) 'Select old brush back CALL DeleteObject(hBrush) 'Delete brush FUNCTION = %TRUE : EXIT FUNCTION CASE %ODA_FOCUS CALL DrawFocusRect(@lpdis.hDC, @lpdis.rcItem) 'draw focus rectangle END SELECT END SELECT FUNCTION = CallWindowProc(oldLBproc, hWnd, wMsg, wParam, lParam) 'process other messages END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Entrance - Create dialog and controls '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION PBMAIN LOCAL hDlg AS LONG, I AS LONG, hList AS LONG REDIM arr(15) AS STRING DIALOG NEW 0, "Color Listbox sample", , , 120, 120, %WS_SYSMENU TO hDlg 'Create items for list arr(0) = "Black" : arr(1) = "Blue" arr(2) = "Green" : arr(3) = "Cyan" arr(4) = "Red" : arr(5) = "Magenta" arr(6) = "Brown" : arr(7) = "Light Gray" arr(8) = "Gray" : arr(9) = "Light Blue" arr(10) = "Light Green" : arr(11) = "Light Cyan" arr(12) = "Light Red" : arr(13) = "Light Magenta" arr(14) = "Yellow" : arr(15) = "Bright White" CONTROL ADD LISTBOX, hDlg, %ID_LIST1, arr(), 5, 5, 106, 80, _ %WS_CHILD OR %LBS_OWNERDRAWFIXED OR %LBS_HASSTRINGS OR _ %WS_TABSTOP OR %LBS_DISABLENOSCROLL OR %WS_VSCROLL, %WS_EX_CLIENTEDGE CONTROL ADD BUTTON, hDlg, %IDOK, "&Close", 30, 85, 60, 14 CONTROL HANDLE hDlg, %ID_LIST1 TO hList 'Subclass listbox oldLBproc = GetWindowLong(hList, %GWL_WNDPROC) SetWindowLong hList, %GWL_WNDPROC, CODEPTR(LBproc) CONTROL SEND hDlg, %ID_LIST1, %LB_SETCURSEL, 10, 0 'Select an item, like 10.. CONTROL SEND hDlg, %ID_LIST1, %LB_SETTOPINDEX, 7, 0 'Make it appear in middle of list DIALOG SHOW MODAL hDlg, CALL DlgProc END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Basic QB color function. "Borrowed" from larger GetQBColor function ' by Chris Boss. Thank you Chris, hope you don't mind.. :-) '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION GetQBColor(BYVAL c AS LONG) AS LONG SELECT CASE c CASE 0 : FUNCTION = RGB(0,0,0) ' Black CASE 1 : FUNCTION = RGB(0,0,128) ' Blue CASE 2 : FUNCTION = RGB(0,128,0) ' Green CASE 3 : FUNCTION = RGB(0,128,128) ' Cyan CASE 4 : FUNCTION = RGB(196,0,0) ' Red CASE 5 : FUNCTION = RGB(128,0,128) ' Magenta CASE 6 : FUNCTION = RGB(128,64,0) ' Brown CASE 7 : FUNCTION = RGB(196,196,196) ' Light Gray CASE 8 : FUNCTION = RGB(128,128,128) ' Gray CASE 9 : FUNCTION = RGB(0,0, 255) ' Light Blue CASE 10 : FUNCTION = RGB(0,255,0) ' Light Green CASE 11 : FUNCTION = RGB(0,255,255) ' Light Cyan CASE 12 : FUNCTION = RGB(255,0,0) ' Light Red CASE 13 : FUNCTION = RGB(255,0,255) ' Light Magenta CASE 14 : FUNCTION = RGB(255,255,0) ' Yellow CASE 15 : FUNCTION = RGB(255,255,255) ' Bright White END SELECT END FUNCTION
control. Sorry, the above is better code..

------------------
[This message has been edited by Borje Hagsten (edited January 23, 2001).]