Guys --
Somebody have a sample ? (I need multine "strings")
------------------
E-MAIL: [email protected]
Somebody have a sample ? (I need multine "strings")
------------------
E-MAIL: [email protected]
#Compile Exe #Dim All #Register None #Include "WIN32API.INC" %ID_LIST1 = 101 %mEl = 10000 CallBack Function DlgProc Dim nEl As Static Long, hList As Long, i As Long Select Case CbMsg Case %WM_INITDIALOG Control Handle CbHndl, %ID_LIST1 To hList Dim arr(%mEl - 1) As Static String i = 50 For nEl = 1 To %mEl i = i + 10: If i > 200 Then i = 50 arr(nEl - 1) = "Item" + Str$(nEl) + " Height =" + Str$(i) SendMessage hList, %LB_ADDSTRING, nEl - 1, 0 SendMessage hList, %LB_SETITEMHEIGHT, nEl - 1, i Next UpdateWindow hList Case %WM_DRAWITEM Local lpdis As DRAWITEMSTRUCT Ptr lpdis = CbLparam If @lpdis.itemID = &HFFFFFFFF Then Exit Function If IsFalse(@lpdis.itemState And %ODS_SELECTED) Then FillRect @lpdis.hDC, @lpdis.rcItem, GetStockObject(%WHITE_BRUSH) SetBkColor @lpdis.hDC, %WHITE SetTextColor @lpdis.hDC, %BLACK ' hOldPen = SelectObject(hDC, CreatePen(%PS_SOLID, 1, c1)) MoveToEx @lpdis.hDC, @lpdis.rcItem.nLeft, @lpdis.rcItem.nBottom - 1, ByVal %NULL LineTo @lpdis.hDC, @lpdis.rcItem.nRight, @lpdis.rcItem.nBottom - 1 Else FillRect @lpdis.hDC, @lpdis.rcItem, GetStockObject(%BLACK_BRUSH) SetBkColor @lpdis.hDC, %BLACK SetTextColor @lpdis.hDC, %WHITE End If i = @lpdis.itemID TextOut @lpdis.hDC, 0, @lpdis.rcItem.ntop, ByVal StrPtr(arr(i)), Len(arr(i)) Function = 1: Exit Function End Select End Function Function PbMain Local hDlg As Long Dialog New 0, "Test", , , 300, 200, %WS_CAPTION Or %WS_SYSMENU To hDlg Control Add ListBox, hDlg, %ID_LIST1, , 5, 5, 280, 190, _ %WS_CHILD Or %LBS_OWNERDRAWVARIABLE Or _ %WS_TABSTOP Or %LBS_DISABLENOSCROLL Or %WS_VSCROLL, %WS_EX_CLIENTEDGE Dialog Show Modal hDlg, Call DlgProc End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Simple SDK-style template '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ #COMPILE EXE #INCLUDE "WIN32API.INC" GLOBAL hInst AS LONG 'instance handle GLOBAL hBtn1 AS LONG 'OK button GLOBAL hBtn2 AS LONG 'Exit button GLOBAL hList AS LONG 'Lisbox handle '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Main entrance '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION WINMAIN (BYVAL hInstance AS LONG, BYVAL hPrevInstance AS LONG, _ lpCmdLine AS ASCIIZ PTR, BYVAL iCmdShow AS LONG) AS LONG LOCAL Msg AS tagMsg LOCAL szAppName AS ASCIIZ * 50 LOCAL hWnd AS LONG LOCAL wndclass AS WndClassEx LOCAL rc AS RECT hInst = hInstance szAppName = "MYPROG" wndclass.cbSize = SIZEOF(WndClass) wndclass.style = %CS_HREDRAW OR %CS_VREDRAW wndclass.lpfnWndProc = CODEPTR( WndProc ) wndclass.hInstance = hInstance wndclass.hCursor = LoadCursor( %NULL, BYVAL %IDC_ARROW ) wndclass.hbrBackground = GetStockObject(%LTGRAY_BRUSH) wndclass.lpszClassName = VARPTR( szAppName ) IF registerClassEx(wndclass) = 0 THEN EXIT FUNCTION 'what else to do..? SystemParametersInfo %SPI_GETWORKAREA, BYVAL 0, VARPTR(rc), 0 'for centering on screen 'Create a window using the registered class hWnd = CreateWindow(szAppName, _ ' window class name "LBS_OWNERDRAWVARIABLE test", _ ' window caption %WS_CAPTION OR %WS_SYSMENU, _ ' window style ((rc.nRight - rc.nLeft) - 300) / 2, _ ' initial x position ((rc.nBottom - rc.nTop) - 200) / 2, _ ' initial y position 300, _ ' initial x size 200,_ ' initial y size %NULL, _ ' parent window handle %NULL, _ ' window menu handle hInstance, _ ' program instance handle BYVAL %NULL) ' creation parameters 'Display the window on the screen ShowWindow hWnd, iCmdShow : UpdateWindow hWnd 'Main message loop: WHILE GetMessage(Msg, %NULL, 0, 0) TranslateMessage Msg DispatchMessage Msg Wend FUNCTION = msg.wParam END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Main dialog procedure '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG SELECT CASE wMsg CASE %WM_CREATE LOCAL I AS LONG, style AS LONG, zTxt AS ASCIIZ * %MAX_PATH style = %WS_CHILD OR %LBS_OWNERDRAWVARIABLE OR %LBS_HASSTRINGS OR %WS_TABSTOP OR %WS_VISIBLE hList = CreateWindowEx(%WS_EX_CLIENTEDGE, "LISTBOX", BYVAL 0, style, _ 8, 8, 278, 120, hwnd, 100, hInst, BYVAL %NULL) FOR I = 0 TO 200 IF I MOD 2 = 0 THEN zTxt = "Line" + STR$(I) & " is a bit long and will wrap against right border of list" SendMessage hList, %LB_ADDSTRING, 0, BYVAL VARPTR(zTxt) ELSE zTxt = "Line" + STR$(I) SendMessage hList, %LB_ADDSTRING, 0, BYVAL VARPTR(zTxt) END IF NEXT style = %BS_PUSHBUTTON + %WS_CHILD + %WS_VISIBLE + %WS_TABSTOP hBtn1 = CreateWindow("BUTTON", "&OK", style, 70, 140, 80, 22, hwnd, 101, hInst, %NULL) hBtn2 = CreateWindow("BUTTON", "E&xit", style, 150, 140, 80, 22, hwnd, 102, hInst, %NULL) SendMessage hwnd, %WM_SETFOCUS, 101, 0 CASE %WM_COMMAND IF wParam = 101 THEN I = SendMessage(hList, %LB_GETCURSEL, 0, 0) CALL SendMessage(hList, %LB_GETTEXT, I, VARPTR(zTxt)) 'Get text MSGBOX zTxt ELSEIF wParam = 102 THEN SendMessage hWnd, %WM_CLOSE, wParam, lParam END IF CASE %WM_MEASUREITEM LOCAL lpmis AS MEASUREITEMSTRUCT PTR lpmis = lParam IF @lpmis.itemID MOD 2 = 0 THEN @lpmis.itemHeight = @lpmis.itemHeight * 2 FUNCTION = %TRUE : EXIT FUNCTION CASE %WM_DRAWITEM LOCAL hBrush AS LONG, hBrushOld AS LONG, rct AS RECT, lpdis AS DRAWITEMSTRUCT PTR lpdis = lParam IF @lpdis.itemID = -1 THEN EXIT FUNCTION SELECT CASE @lpdis.itemAction CASE %ODA_DRAWENTIRE, %ODA_SELECT 'CLEAR BACKGROUND hBrush = CreateSolidBrush(GetSysColor(%COLOR_INFOBK)) '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_INFOBK)) 'Set text Background CALL SetTextColor(@lpdis.hDC, GetSysColor(%COLOR_INFOTEXT)) 'Set text color CALL SendMessage(hList, %LB_GETTEXT, @lpdis.itemID, VARPTR(zTxt)) 'Get text to paint CALL DrawText(@lpdis.hDC, zTxt, LEN(zTxt), @lpdis.rcItem, _ %DT_EXPANDTABS OR %DT_NOPREFIX OR %DT_WORDBREAK) 'SELECTED ITEM IF (@lpdis.itemState AND %ODS_SELECTED) THEN 'if selected CALL InvertRect(@lpdis.hDC, @lpdis.rcItem) 'invert area around text only END IF FUNCTION = %TRUE : EXIT FUNCTION CASE %ODA_FOCUS CALL DrawFocusRect(@lpdis.hDC, @lpdis.rcItem) 'draw focus rectangle FUNCTION = %TRUE : EXIT FUNCTION END SELECT CASE %WM_DESTROY PostQuitMessage 0 FUNCTION = 0 : EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION
InflateRect @lpdis.rcItem, -4, -4 '<- need to make rect a bit smaller if to draw on 3D borders.. SetBkMode @lpdis.hDC, %TRANSPARENT '<- this one if to draw text on 3D "button" borders.. CALL DrawText(@lpdis.hDC, BYVAL STRPTR(arr(i)), LEN(arr(i)), @lpdis.rcItem, _ %DT_EXPANDTABS OR %DT_NOPREFIX OR %DT_WORDBREAK)
IF ISFALSE(@lpdis.itemState AND %ODS_SELECTED) THEN CALL DrawFrameControl(@lpdis.hDC, @lpdis.rcItem, %DFC_BUTTON, %DFCS_BUTTONPUSH) ELSE
' if DrawFrameControl was used to produce 3D items, following removes flicker.. CASE %WM_CTLCOLORLISTBOX FUNCTION = GetSysColorBrush(%COLOR_3DFACE) EXIT FUNCTION
#Compile Exe #Dim All #Register None #Include "WIN32API.INC" %ID_LIST1 = 101 %mEl = 100 CallBack Function DlgProc Dim nEl As Long, i As Long, j As Long, lpdis As DRAWITEMSTRUCT Ptr, rc As RECT, tmp As Asciiz * 6 Static hList As Long, hBrushListF As Long, hBrushListS As Long, hBrushListU As Long, hPenList As Long Select Case CbMsg Case %WM_INITDIALOG Control Handle CbHndl, %ID_LIST1 To hList Dim arr(%mEl - 1) As Static String Randomize GetTickCount i = 50 For nEl = 0 To %mEl - 1 i = Rnd(1) * 50 + 20 arr(nEl) = "Height =" + Str$(i) SendMessage hList, %LB_ADDSTRING, nEl, 0 SendMessage hList, %LB_SETITEMHEIGHT, nEl, i Next UpdateWindow hList hPenList = CreatePen(%PS_SOLID, 1, %GRAY) hBrushListF = CreateSolidBrush(&H808080) hBrushListS = CreateSolidBrush(&H800000) hBrushListU = CreateSolidBrush(&HFFC0FF) Case %WM_DESTROY DeleteObject hPenList DeleteObject hBrushListF DeleteObject hBrushListU DeleteObject hBrushListS Case %WM_CTLCOLORLISTBOX If CbLparam = hList Then Function = GetStockObject(%NULL_BRUSH) Case %WM_DRAWITEM lpdis = CbLparam i = @lpdis.itemID: If i = -1 Then Exit Function '=========================================================== If i = %mEl - 1 Then GetClientRect hList, rc rc.nTop = @lpdis.rcItem.nBottom FillRect @lpdis.hDC, rc, GetStockObject(%GRAY_BRUSH) End If '=========================================================== j = @lpdis.rcItem.nRight @lpdis.rcItem.nRight = 0.15 * j DrawFrameControl @lpdis.hDC, @lpdis.rcItem, %DFC_BUTTON, %DFCS_BUTTONPUSH SetBkMode @lpdis.hDC, %TRANSPARENT SetTextColor @lpdis.hDC, %BLUE tmp = Format$(i + 1) DrawText @lpdis.hDC, tmp, Len(tmp), @lpdis.rcItem, _ %DT_SINGLELINE Or %DT_CENTER Or %DT_VCENTER @lpdis.rcItem.nLeft = @lpdis.rcItem.nRight @lpdis.rcItem.nRight = j If IsFalse(@lpdis.itemState And %ODS_SELECTED) Then FillRect @lpdis.hDC, @lpdis.rcItem, hBrushListU SetTextColor @lpdis.hDC, %BLACK Else FillRect @lpdis.hDC, @lpdis.rcItem, hBrushListS SetTextColor @lpdis.hDC, %WHITE End If SelectObject @lpdis.hDC, hPenList MoveToEx @lpdis.hDC, @lpdis.rcItem.nLeft, @lpdis.rcItem.nBottom - 1, ByVal %NULL LineTo @lpdis.hDC, @lpdis.rcItem.nRight, @lpdis.rcItem.nBottom - 1 InflateRect @lpdis.rcItem, -5, 0 Call DrawText(@lpdis.hDC, ByVal StrPtr(arr(i)), Len(arr(i)), @lpdis.rcItem, _ %DT_EXPANDTABS Or %DT_NOPREFIX Or %DT_WORDBREAK Or %DT_VCENTER Or %DT_SINGLELINE) Function = 1: Exit Function End Select End Function Function PbMain Local hDlg As Long Dialog New 0, "Test", , , 300, 200, %WS_CAPTION Or %WS_SYSMENU To hDlg Control Add ListBox, hDlg, %ID_LIST1, , 5, 5, 280, 190, _ %WS_CHILD Or %LBS_OWNERDRAWVARIABLE Or _ %WS_TABSTOP Or %LBS_DISABLENOSCROLL Or %WS_VSCROLL, %WS_EX_CLIENTEDGE Dialog Show Modal hDlg, Call DlgProc End Function
Case %WM_ERASEBKGND Call SendMessage( hWnd, %CP_GETBACKCOLOR, 0, ByVal 0& ) '// Paint the background. @DBP.hBrush = CreateSolidBrush( @DBP.cBackColor ) If @DBP.hBrush Then GetClientRect hWnd, R FillRect wParam, R, @DBP.hBrush DeleteObject @DBP.hBrush Function = 1 Exit Function End If Case %WM_PAINT '// Don't let the background get repainted by it's parent when empty a = SendMessage( hWnd, %LB_GETCOUNT, 0, ByVal 0& ) If a = 0 Then BeginPaint hWnd, ps EndPaint hWnd, ps Function = 0 Exit Function End If
We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.
By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.
Comment