Tweet
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).]