So (ähnlich) werde ich es jetzt mal einsetzen.
Tatsächlich habe ich noch eine Konstante gefunden, die wohl noch nicht in PB definiert ist.... #LBS_NOSEL
Happy Coding und schön Gesund bleiben.
Code:
;'
;' CreateWindowEx_(..., LISTBOX, ...), #LBS_OWNERDRAWFIXED, #LBS_NODATA example...
;'
EnableExplicit
DebugLevel 9 ;' show all Debug Messages
;' windows api constant (missing in PB)
#LBS_NOSEL = $00004000 ;' 0x4000 ... in ListViewGadget()
;' used Gadgets, Windows, Controls, etc.
;
Enumeration EWindow ;' named enums -- used in the same way in include files
#WINDOW_Main
EndEnumeration
Enumeration EGadget
EndEnumeration
;' the global data (example)
#APP_ARRAY_MAXSIZE = 30
Global Dim App_Text$(#APP_ARRAY_MAXSIZE) ;'
;' helper macros
Macro LOWORD(nLong)
((nLong) & $FFFF)
EndMacro
Macro HIWORD(nLong)
(((nLong) >> 16) & $FFFF)
EndMacro
;' helper procedures
Procedure InitArr() ;' fill example array with some lines of text
Protected nn
Debug "Set arr$("+Str(ArraySize(App_Text$()))+") "
For nn = 0 To ArraySize(App_Text$())
App_Text$(nn) = "Array Item #"+RSet(Str(nn), 2, "0") ;'
If nn % 10 = 0
App_Text$(nn) + " every 10th line is longer than the others :-) "
EndIf
;
; Debug " arr("+nn+") = '"+arr$(nn)+"'"
Next nn
App_Text$(0) + "First Line"
App_Text$(#APP_ARRAY_MAXSIZE) + "Last Line"
EndProcedure : InitArr()
;---------------------------------------------------------------------------------------------------------------------
;' Main Window and Main Program
Procedure __MainWindowSubClassProc(hWnd, uMsg, wParam, lParam) ;' subclass callback
Static hBrushBgOdd, hBrushBgEven
Static lfMessageFont.LOGFONT ;' used for drawitem
Protected result, rc.RECT, sz.SIZE, lf.LOGFONT
Protected idx, item$, tx$, Checkbox$
Protected xSelected, dtFlags, currentTextColor, hFont, hOldFont, hLb, ww, wh, w, h
Protected *lpdis.DRAWITEMSTRUCT, *mis.MEASUREITEMSTRUCT, ncm.NONCLIENTMETRICS
Select uMsg
Case -1 ;- call with uMsg == -1 to initial the callback
hBrushBgOdd = CreateSolidBrush_(GetSysColor_(#COLOR_INFOBK)) ;' background of the control
hBrushBgEven = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW)) ;' background of the control
SetWindowLongPtr_(hWnd, #GWL_USERDATA, GetWindowLongPtr_(hWnd, #GWL_WNDPROC)) ;' keep the window procedure address
SetWindowLongPtr_(hWnd, #GWL_WNDPROC, @__MainWindowSubClassProc()) ;' set window procedure to my subclass callback procedure
;' get the correct font !!!
ncm\cbSize = SizeOf(NONCLIENTMETRICS)
If SystemParametersInfo_(#SPI_GETNONCLIENTMETRICS, SizeOf(NONCLIENTMETRICS), @ncm, 0) <> 0
Debug "Used Message Font = '"+PeekS(@ncm\lfMessageFont\lfFaceName)+"'"
CopyStructure(@ncm\lfMessageFont, @lfMessageFont, LOGFONT) ;' make info static
EndIf
Case #WM_NCDESTROY :Debug "subclass: WM_NCDESTROY ", 9
DeleteObject_(hBrushBgOdd)
DeleteObject_(hBrushBgEven)
; Case #WM_DESTROY :Debug "subclass: WM_DESTROY --> do nothing "
Case #WM_MEASUREITEM ;:Debug "subclass: WM_MEASUREITEM "
*mis = lParam :Debug "subclass: WM_MEASUREITEM ItemHeight = "+Str(*mis\itemHeight), 9
*mis\itemHeight + 8
ProcedureReturn 1 ;' according to msdn
Case #WM_SIZE
w = LOWORD(lParam) ;' // width of client area
h = HIWORD(lParam) ;' // height of client area
Select wParam
;Case #SIZE_MINIMIZED :Debug "Window was minimized "+w+", "+h
Case #SIZE_RESTORED :Debug "Window was restored "+w+", "+h
hLb = GetWindow_(hWnd, #GW_CHILD) :Debug "hListbox = "+hLb+" ??? "
MoveWindow_(hLb, 0, 0, w, h, 1) ;'
;Case #SIZE_MAXIMIZED :Debug "Window was maximized "+w+", "+h
EndSelect
Case #WM_DRAWITEM ;:Debug "subclass: WM_DRAWITEM, "+wParam+", "+lParam
*lpdis = lParam
idx = *lpdis\itemID ;:Debug " idx = "+idx
If *lpdis\itemID <> -1
item$ = App_Text$(idx) ;:Debug " Item["+idx+"] = '"+item$+"'"
If idx % 2 = 0
FillRect_(*lpdis\hdc, *lpdis\rcItem, hBrushBgEven) ;' clear item rect with background color
Else
FillRect_(*lpdis\hdc, *lpdis\rcItem, hBrushBgOdd) ;' clear item rect with background color
EndIf
SetBkMode_(*lpdis\hdc, #TRANSPARENT)
SetTextColor_(*lpdis\hdc, #Blue) ;' #Black, and all his friends ...
hFont = CreateFontIndirect_(lfMessageFont) ;:Debug "hFont = "+hFont
hOldFont = SelectObject_(*lpdis\hdc, hFont) ;:Debug "hOldFont = "+hOldFont
dtFlags = #DT_LEFT|#DT_WORDBREAK|#DT_END_ELLIPSIS
rc = *lpdis\rcItem
rc\left + 8 ;' --> left margin
rc\top + 4 ;' --> vertical center text in line (see ItemHeight change in #WM_MEASUREITEM message)
DrawText_(*lpdis\hdc, item$, Len(item$), rc, dtFlags)
;TextOut_(*lpdis\hdc, *lpdis\rcItem\left+2, *lpdis\rcItem\top + 2, @item$, Len(item$))
SelectObject_(*lpdis\hdc, hOldFont) ;' reset the font
DeleteObject_(hFont)
;'' default --> show the text in default font of createwindowex_(..., "Listbox", ...) ???
item$ = ":"+Str(idx)+":"
rc\left + 400 ;(rc\right-64)
DrawText_(*lpdis\hdc, item$, Len(item$), rc, dtFlags)
ProcedureReturn 1 ;' according to msdn
EndIf
EndSelect ; uMsg
ProcedureReturn CallWindowProc_(GetWindowLongPtr_(hWnd, #GWL_USERDATA), hWnd, uMsg, wParam, lParam) ;' use stored window procedure address
EndProcedure ;__MainWindowSubClassProc()
Procedure.i OpenMainWindow(WndW=640, WndH=480) ;' returns hWnd
Protected hWnd, hListBox, hInstance
Protected rc
#Window_Style = #PB_Window_SystemMenu|#PB_Window_SizeGadget|#PB_Window_ScreenCentered
hWnd = OpenWindow(#WINDOW_Main, 0, 0, WndW, WndH, "LISTBOX, #LBS_OWNERDRAWFIXED, #LBS_NODATA example...", #Window_Style)
If hWnd <> 0
__MainWindowSubClassProc(hWnd, -1, 0, 0) ;' strange, but works :-)
hInstance = GetModuleHandle_(0)
#LISTBOX_Style = #WS_CHILD|#WS_VSCROLL|#WS_VISIBLE|
#LBS_NOTIFY|
#LBS_NOINTEGRALHEIGHT| ;' resize looks different
#LBS_DISABLENOSCROLL| ;' together with #W_VSCROLL .. control the visibility of scrollbar
#LBS_NOSEL| ;' ...
#LBS_OWNERDRAWFIXED|#LBS_NODATA ;' this is what I want
hListBox = CreateWindowEx_(#WS_EX_CLIENTEDGE, "ListBox", 0, #LISTBOX_Style, 0, 0, WndW, WndH, hWnd, 0, hInstance, #Null)
Debug "hListbox = " + hListBox
Debug "Style.0 = 0x"+Hex(GetWindowLong_(hListBox, #GWL_STYLE), #PB_Long)
;' MSDN: this is used with #LBS_NODATA
Debug "Set hListbox to "+Str(ArraySize(App_Text$()))+" items "
rc = SendMessage_(hListBox, #LB_SETCOUNT, ArraySize(App_Text$())+1, 0) :Debug "SendMessage_(hListBox, #LB_SETCOUNT, ...) => "+rc
rc = SendMessage_(hListBox, #LB_GETCOUNT, 0, 0) :Debug "SendMessage_(hListBox, #LB_GETCOUNT, ...) => "+rc
EndIf
ProcedureReturn hWnd
EndProcedure ;()
Procedure.i MainProgram()
Protected Event
If OpenMainWindow()
Repeat
Event = WaitWindowEvent()
Select Event
Case #PB_Event_Gadget :Debug "Listbox clicked!" ;' weird by okay
; Select EventGadget()
; EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow
EndIf
ProcedureReturn 0
EndProcedure ;()
End MainProgram()
FAQ
Suche
Registrieren
Anmelden
