Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

PB/DLL 6, Ownerdrawn color Listbox..

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PB/DLL 6, Ownerdrawn color Listbox..

    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
    Corrected: Entire code! Discovered I was subclassing dialog, not
    control. Sorry, the above is better code..

    ------------------


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