Tweet
Following code is a VB-style dir listbox that works fine. Ownerdrawn,
so items are drawn in subclassed procedure, under %WM_DRAWITEM. One
thing left to solve, and I can't understand how.
It seems like I have to pass the %WM_DRAWITEM message on from parent
dialog for it to work. Would like to make it handle all this by
itself, without having to pass any calls on from the parent, but
can't find a way of doing it.
If you test the following code, all looks fine (I hope). Uncomment
the code under %WM_DRAWITEM in main dialog callback, DlgProc, and
nothing is drawn in the listbox. Feels like there should be an easy
solution to this, to make the control handle all this by itself,
but no matter how I try, I can't solve it. I'm probably stupid.. (probably?)
------------------
so items are drawn in subclassed procedure, under %WM_DRAWITEM. One
thing left to solve, and I can't understand how.
It seems like I have to pass the %WM_DRAWITEM message on from parent
dialog for it to work. Would like to make it handle all this by
itself, without having to pass any calls on from the parent, but
can't find a way of doing it.
If you test the following code, all looks fine (I hope). Uncomment
the code under %WM_DRAWITEM in main dialog callback, DlgProc, and
nothing is drawn in the listbox. Feels like there should be an easy
solution to this, to make the control handle all this by itself,
but no matter how I try, I can't solve it. I'm probably stupid.. (probably?)
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Directory listbox - by Borje Hagsten, January 2001.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' VB style Dir listbox sample.. :-)
'
' Public Domain, feel free to use and customize as you like.
' Code is commented, should be easy to follow. GDI stuff seems safe,
' no leaks. Still, as always, use at own "risk".. :-)
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Declares
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
#COMPILE EXE
#INCLUDE "WIN32API.INC"
%ID_BTN1 = 10
%ID_DIR1 = 130
GLOBAL oldLBproc AS LONG 'for subclassing, to hold original window procedure address
DECLARE CALLBACK FUNCTION DlgProc
DECLARE FUNCTION LBproc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
DECLARE SUB DirsToList(BYVAL hWnd AS LONG, BYVAL AbsPath AS STRING)
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Entrance - Create dialog and controls
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
FUNCTION PBMAIN
LOCAL hDlg AS LONG, hDirList AS LONG
DIALOG NEW 0, "Dir List sample", , , 120, 120, %WS_SYSMENU TO hDlg
CONTROL ADD BUTTON, hDlg, %ID_BTN1, "&Close", 30, 85, 60, 14
CONTROL ADD LISTBOX, hDlg, %ID_DIR1, , 4, 4, 108, 80, _
%WS_CHILD OR %LBS_OWNERDRAWFIXED OR %LBS_HASSTRINGS OR _
%WS_TABSTOP OR %LBS_DISABLENOSCROLL OR %WS_VSCROLL, %WS_EX_CLIENTEDGE
CONTROL HANDLE hDlg, %ID_DIR1 TO hDirList 'Subclass Dirlistbox
oldLBproc = SetWindowLong(hDirList, %GWL_WNDPROC, CODEPTR(LBproc))
CALL DirsToList(hDirList, CURDIR$) 'initialize to whatever path, like CURDIR$
DIALOG SHOW MODAL hDlg, CALL DlgProc
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Main dialog callback
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
CALLBACK FUNCTION DlgProc
SELECT CASE CBMSG
CASE %WM_COMMAND
SELECT CASE CBCTL
CASE %ID_BTN1 : DIALOG END CBHNDL 'Exit
CASE %ID_DIR1
END SELECT
CASE %WM_DESTROY 'Un-subclass listbox
SetWindowLong GetDlgItem(CBHNDL, %ID_DIR1), %GWL_WNDPROC, oldLBproc
CASE %WM_DRAWITEM 'Must pass this on to subclassed control, wonder why..?
IF CBWPARAM = %ID_DIR1 THEN
SendMessage GetDlgItem(CBHNDL, %ID_DIR1), CBMSG, CBWPARAM, CBLPARAM
FUNCTION = 0: EXIT FUNCTION
END IF
END SELECT
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Subclassed DirListbox procedure
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
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_GETDLGCODE 'make sure we get all keys
FUNCTION = %DLGC_WANTALLKEYS : EXIT FUNCTION
CASE %WM_KEYDOWN 'respond to keyboard input
SELECT CASE wParam
CASE %VK_RETURN 'Enter key
CALL DirsToList(hWnd, "")
FUNCTION = 0 : EXIT FUNCTION
CASE %VK_TAB 'must handle Tab ourselves, since we have taken full controll..
IF HIWRD(GetKeyState(%VK_SHIFT)) = 0 THEN
SetFocus GetNextDlgTabItem(GetParent(hWnd), hWnd, 0) 'Move focus to next control
ELSE 'If Shift is pressed -
SetFocus GetNextDlgTabItem(GetParent(hWnd), hWnd, -1) 'Move focus to previous control
END IF
FUNCTION = 0 : EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDBLCLK 'respond to double-click
CALL DirsToList(hWnd, "")
FUNCTION = 0 : EXIT FUNCTION
CASE %WM_DRAWITEM 'Ownerdrawn = owner draws all items self (programmer = owner)
LOCAL lpdis AS DRAWITEMSTRUCT PTR
lpdis = lParam
IF @lpdis.itemID = -1 THEN EXIT FUNCTION 'empty list, take a break..
SELECT CASE @lpdis.itemAction
CASE %ODA_DRAWENTIRE, %ODA_SELECT
LOCAL lpshfi AS SHFILEINFO, tm AS TEXTMETRIC, zTxt AS ASCIIZ * %MAX_PATH, rct AS RECT
LOCAL hBrush AS LONG, hBrushOld AS LONG, img AS LONG, it AS LONG, xPos AS LONG, y AS LONG
'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
'GET SELECTED TEXT AND CALCULATE X POSITION
CALL SendMessage(hWnd, %LB_GETTEXT, @lpdis.itemID, VARPTR(zTxt)) 'Get selected text
it = SendMessage(hWnd, %LB_GETITEMDATA, @lpdis.itemID, 0)
xPos = (TALLY(zTxt, "\") + it - 1) * 3 ' * 3 decides x pos between opened folders
'GET SMALL ASSOCIATED ICON AND TEXT TO DISPLAY
IF it <> 1 THEN
img = SHGetFileInfo(zTxt, 0, lpshfi, LEN(lpshfi), %SHGFI_DISPLAYNAME OR %SHGFI_ICON OR %SHGFI_SMALLICON)
ELSE
img = SHGetFileInfo(zTxt, 0, lpshfi, LEN(lpshfi), %SHGFI_DISPLAYNAME OR %SHGFI_ICON OR %SHGFI_SMALLICON OR %SHGFI_OPENICON)
END IF
'ADJUST ITEM HEIGHT TO FONT SIZE
CALL GetTextMetrics(@lpdis.hDC, tm) 'get font size
y = (@lpdis.rcItem.nBottom + @lpdis.rcItem.nTop - tm.tmHeight) / 2 'Center text ypos
IF SendMessage(hWnd, %CB_GETITEMHEIGHT, @lpdis.itemID, 0) < tm.tmHeight + 2 THEN
CALL SendMessage(hWnd, %CB_SETITEMHEIGHT, @lpdis.itemID, tm.tmHeight + 2) 'adjust item height
END IF
'DRAW TEXT
CALL SetBkColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOW)) 'Set text Background
CALL SetTextColor(@lpdis.hDC, GetSysColor(%COLOR_WINDOWTEXT)) 'Set text color
IF @lpdis.itemID = 0 THEN lpshfi.szDisplayName = UCASE$(zTxt) 'First item, drive, UCASE
CALL TextOut(@lpdis.hDC, xPos + 22, y, lpshfi.szDisplayName, LEN(lpshfi.szDisplayName)) 'Draw text
'SELECTED ITEM
IF (@lpdis.itemState AND %ODS_SELECTED) THEN 'if selected
CALL InvertRect(@lpdis.hDC, @lpdis.rcItem) 'invert area around text only
END IF
'DRAW ASSOCIATED ICON
DrawIconEx @lpdis.hDC, xPos + 3, @lpdis.rcItem.ntop, _
lpshfi.hIcon, 16, 15, 0, BYVAL %NULL, %DI_NORMAL
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) 'pass all other messages on to orig. proc.
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Populate DirListbox with available directories
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
SUB DirsToList(BYVAL hWnd AS LONG, BYVAL AbsPath AS STRING)
LOCAL hSearch AS LONG, fRes AS LONG, Path AS STRING, s AS STRING, arr() AS STRING, dc AS LONG
LOCAL WFD AS WIN32_FIND_DATA, I AS LONG, J AS LONG
IF LEN(AbsPath) = 0 THEN 'if nothing has been passed, look for selected item
I = SendMessage(hWnd, %LB_GETCURSEL, 0, 0)
J = SendMessage(hWnd, %LB_GETTEXTLEN, I, 0)
AbsPath = SPACE$(J)
I = SendMessage(hWnd, %LB_GETTEXT, I, BYVAL STRPTR(AbsPath))
END IF
IF LEN(AbsPath) = 0 THEN EXIT SUB 'if something bad has happened
IF RIGHT$(AbsPath, 1) <> "\" THEN AbsPath = AbsPath & "\" 'make sure we have a trailing backslash
Path = AbsPath 'store for later use
AbsPath = AbsPath + "*" 'for finding all subsequent folders
FOR I = 1 TO PARSECOUNT(Path, "\") - 1 'Parse current path and add opened folders to array
s = s + PARSE$(Path, "\", I)
IF LEN(s) THEN
REDIM PRESERVE arr(dc)
IF RIGHT$(s, 1) <> "\" THEN s = s & "\"
arr(dc) = s
INCR dc
END IF
NEXT I
J = dc - 1
hSearch = FindFirstFile(BYVAL STRPTR(AbsPath), WFD) 'Find all following non-opened sub-folders
IF hSearch <> %INVALID_HANDLE_VALUE THEN
CALL SendMessage(hWnd, %CB_RESETCONTENT, 0, 0)
fRes = %TRUE
DO WHILE fRes
IF ASC(WFD.cFileName) <> 46 THEN 'No . or ..
IF (WFD.dwFileAttributes AND 16) = 16 THEN 'dirs only..
AbsPath = TRIM$(WFD.cFileName, CHR$(0))
REDIM PRESERVE arr(dc)
arr(dc) = Path + AbsPath
INCR dc
END IF
END IF
fRes = FindNextFile(hSearch, WFD) ' Get next
LOOP
fRes = FindClose(hSearch)
END IF
ARRAY SORT arr(J), COLLATE UCASE 'sort non-opened folders only
CALL SendMessage(hWnd, %LB_RESETCONTENT, 0, 0) 'clear list
FOR I = 0 TO UBOUND(arr)
CALL SendMessage(hWnd, %LB_ADDSTRING, 0, BYVAL STRPTR(arr(I))) 'add to list
IF I = 0 THEN 'Set item data for chosing type of *** . icon
CALL SendMessage(hWnd, %LB_SETITEMDATA, I, 0) 'Drive
ELSEIF I = < J THEN
CALL SendMessage(hWnd, %LB_SETITEMDATA, I, 1) 'opened folder
ELSE
CALL SendMessage(hWnd, %LB_SETITEMDATA, I, 2) 'closed folder
END IF
NEXT
CALL SendMessage(hWnd, %LB_SELECTSTRING, -1, BYVAL STRPTR(Path)) 'select current
'Note - here is good place to fill a file listbox.
'Can use same FindFirstFile loop as above, but use
'"IF (WFD.dwFileAttributes AND 16) <> 16" instead,
'to get file names for an ordinary listbox, whatever.
END SUB
------------------
Comment