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

Custom Control Properties ListBox

Collapse
X
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
    #1

    Custom Control Properties ListBox

    Added Feb. 6, 2001 Found Author name and link to origional code...
    http://codeguru.earthweb.com/listbox/PropListBox.shtml

    A Properties ListBox to aid in the development of User Designed custom controls.

    Origional Code was found at the Great Guru site. It was an MFC C++
    example. No mention to who the origional Author was. Even though I
    no nothing about C,C++, there was enough details to make some good
    guesses for the conversion to PowerBasic.

    Thanks to the following People:
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -Errol Cheverie and Jim Seekamp for suppling good Owner Draw Listboxes examples.
    -Semen Matusovski for his heads up on the COLORREFF Value. (M$ reversed RGB scheme)
    -Dominic Mitchell for his heads up on the WM_CAPTURECHANGED message. (gracefully exit from Setcapture)
    -Eric Pearson, for his ChooseColor() dialog code example.
    -Ian Cairns, for his ChooseFont() dialog code example.
    -Dave Navarro for this MakeFont code example.

    And a very special thanks to:
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    -Borje Hagsten, I used his Poffs.Exe EXTENSIVELY during the development cycle. An
    indespencable tool.

    And don't foget to try out the Splitter function.

    Regards,
    Jules

    Code:
    '--------------------------------------------------------------------------------------------
' Module:  ListProp.Bas    
' Desc:    OwnerDraw ListBox 
' Purpose: For exploring "User Desinged" custom control properties <adding later>
' Date:    Jan. 23, 2001
' Name:    By Jules Marchildon  <[email protected]>
'--------------------------------------------------------------------------------------------
  
#COMPILE EXE
#INCLUDE "WIN32API.INC"
#INCLUDE "COMDLG32.INC"
  
'---
DECLARE SUB InitializePropertyItems()
DECLARE SUB InitializeCustomColors()
DECLARE SUB InitializeUserCustomControl()
DECLARE SUB OnSelchange()
DECLARE SUB OnButtonClicked()
DECLARE SUB InvertLine( ByVal xleft1 AS INTEGER ,ByVal yFrom AS INTEGER ,ByVal xleft2 AS INTEGER ,ByVal yTo AS INTEGER)
DECLARE FUNCTION MakeFont(BYVAL Font AS STRING, BYVAL PointSize AS LONG) AS LONG
  
'---
GLOBAL ghInst   AS LONG
GLOBAL ghMain   AS LONG
GLOBAL ghList   AS LONG
GLOBAL ghButton AS LONG
GLOBAL ghCombo  AS LONG
GLOBAL ghEdit   AS LONG
GLOBAL ghFont   AS LONG
GLOBAL ghUCC    AS LONG
  
GLOBAL lpOldListProc  AS LONG
  
GLOBAL curSel         AS INTEGER
GLOBAL prevSel        AS INTEGER
GLOBAL nDivider       AS INTEGER
GLOBAL nDivTop        AS INTEGER
GLOBAL nDivBtm        AS INTEGER
GLOBAL nOldDivX       AS INTEGER
GLOBAL nLastBox       AS INTEGER
GLOBAL bTracking      AS LONG
GLOBAL bDivIsSet      AS INTEGER
  
GLOBAL hCursorArrow   AS LONG
GLOBAL hCursorSize    AS LONG
GLOBAL cColor()       AS LONG
  

'---
TYPE PROPERTYITEM
  propName  AS ASCIIZ*225
  curValue  AS ASCIIZ*255
  nItemType AS INTEGER
  cmbItems  AS ASCIIZ*255
END TYPE
  
GLOBAL pItem()  AS PROPERTYITEM 'details for User designed custom control
  
'---
%IDC_LISTBOX = 1000
%IDC_COMBO   = 1001
%IDC_BUTTON  = 1002
%IDC_EDIT    = 1003
%IDC_UCC     = 1004
  
'PIT = property item type, Button is default
%PIT_COMBO   = 0
%PIT_EDIT    = 1
%PIT_COLOR   = 2
%PIT_FONT    = 3
%PIT_FILE    = 4
  
'-------------------------------------------------------------
' WinMain:
'
'
'-------------------------------------------------------------
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 wndclass  AS WndClassEx
    LOCAL hWnd      AS LONG
    LOCAL rct       AS RECT
    LOCAL szpgmname AS ASCIIZ * 20
  
    szpgmname = "PROPLIST"
  
    wndclass.cbSize        = SIZEOF(WndClass)
    wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW OR %CS_DBLCLKS
    wndclass.lpfnWndProc   = CODEPTR( MainWndProc )
    wndclass.cbClsExtra    = 0
    wndclass.cbWndExtra    = 0
    wndclass.hInstance     = hInstance
    wndclass.hIcon         = LoadIcon( hInstance, "MAINICON" )
    wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )
    wndclass.hbrBackground = GetStockObject( %LTGRAY_BRUSH )
    wndclass.lpszMenuName  = %NULL
    wndclass.lpszClassName = VARPTR(szpgmname)
    wndclass.hIconSm       = LoadIcon(hInstance, BYVAL %IDI_APPLICATION)
  
    RegisterClassEx wndclass
  
    ghInst = hInstance
  
    style& = %WS_OVERLAPPED OR _
             %WS_CAPTION OR _
             %WS_SYSMENU OR _ '%WS_SIZEBOX OR _
             %WS_MINIMIZEBOX
  
    'create the main window (my screen LCD,1024x768)
    hWnd = CreateWindowEx(0, _
                szpgmname, _
                "Control Properties:", _
                style&, _
                210, _
                110, _
                650, _
                350, _
                %HWND_DESKTOP, _
                %NULL, _
                hInstance, _
                BYVAL %NULL)
  

    Call ShowWindow( hWnd, %SW_SHOW )
    Call UpdateWindow( hWnd )
  
    WHILE GetMessage(Msg, %NULL, 0, 0)
        TranslateMessage Msg
        DispatchMessage Msg
    WEND
  
    FUNCTION = msg.wParam
  
END FUNCTION

  
'------------------------------------------------------------------------
'
' MainWndProc()
'
'------------------------------------------------------------------------
FUNCTION MainWndProc(ByVal hWnd AS LONG,ByVal wMsg AS LONG, _
                     ByVal wParam AS LONG,ByVal lParam AS LONG) AS LONG
  
    LOCAL lpDs      AS DRAWITEMSTRUCT PTR
    LOCAL lpMs      AS MEASUREITEMSTRUCT PTR
    LOCAL hBrush    AS LONG
  
    LOCAL rc        AS RECT
    LOCAL rectFull  AS RECT
    LOCAL rc2       AS RECT
    LOCAL nIndex    AS INTEGER
  

    ghMain = hWnd
  
'---
SELECT CASE wMsg
    CASE %WM_CREATE
  

            DIM pItem(0:16) AS PROPERTYITEM
 
            bTracking = %FALSE
            nDivider  = 0
            bDivIsSet = %FALSE
            curSel    = 1
  
            hCursorArrow =  LoadCursor( %NULL, ByVal %IDC_ARROW )
            hCursorSize  =  LoadCursor( %NULL, ByVal %IDC_SIZEWE )
  
            ghFont = MakeFont("MS San Sarif", 9)
  
            '  Create the OwnerDraw List box for our control properties...
            ghList   = CreateWindowEx(%WS_EX_CLIENTEDGE, "LISTBOX", "", _
                                     %WS_CHILD OR %WS_VISIBLE OR _
                                     %WS_TABSTOP OR %WS_BORDER OR _
                                     %LBS_NOINTEGRALHEIGHT OR _
                                     %LBS_HASSTRINGS OR _
                                     %LBS_OWNERDRAWFIXED OR _
                                     %LBS_NOTIFY OR _
                                     %WS_VSCROLL, _
                                     10,10,300,306, _
                                     ghMain, _
                                     %IDC_LISTBOX, _
                                     ghInst, BYVAL %NULL)
  
            'SubClass the ListBox
            lpOldListProc = SetWindowLong( ghList,%GWL_WNDPROC,ByVal CodePtr(ListBoxProc) )
  
            Call SendMessage( ghList, %WM_SETFONT, ghFont, 0 )
  
            '  Create the controls that will need to edit the Properties with.
            '  They are all hidden for now and resized later.
            ghButton = CreateWindowEx(0,"BUTTON","...", _
                                      %WS_CHILD OR %WS_CLIPSIBLINGS OR _
                                      %BS_PUSHBUTTON, _
                                      0,0,8,12, _
                                      ghList, _
                                      %IDC_BUTTON,   _
                                      ghInst, ByVal %NULL)
  
            Call SendMessage( ghButton, %WM_SETFONT, ghFont, 0 )
  
            ghCombo  = CreateWindowEx(0,"COMBOBOX", "", _
                                      %WS_CHILD OR _
                                      %CBS_DROPDOWNLIST _
                                      OR %CBS_NOINTEGRALHEIGHT, _
                                      0,0,10,100, _
                                      ghList, _
                                      %IDC_COMBO, _
                                      ghInst, BYVAL %NULL)
  
            Call SendMessage( ghCombo, %WM_SETFONT, ghFont, 0 )
   
            ghEdit   = CreateWindowEx(0,"EDIT", "True", _
                                      %WS_CHILD OR %WS_CLIPSIBLINGS OR _
                                      %ES_LEFT OR %ES_AUTOHSCROLL OR %WS_BORDER, _
                                      0,0,10,20, _
                                      ghList, _
                                      %IDC_EDIT,_
                                      ghInst, ByVal %NULL)
  
            Call SendMessage( ghEdit, %WM_SETFONT, ghFont, 0 )
            '-------------------------------------------------------------------
  
            '  This call must be done AFTER the listbox has been created!
            Call InitializePropertyItems()
            Call InitializeCustomColors()
  
            '  Add our User designed Custom Control
            Call InitializeUserCustomControl()
  
            FUNCTION = %TRUE
            EXIT FUNCTION
  

    CASE %WM_MEASUREITEM
  
         lpMs = lParam
         'arbitrary number for height
         @lpMs.itemHeight = 20
  
         FUNCTION = %TRUE
         EXIT FUNCTION
  

    CASE %WM_DRAWITEM
  
        lpDs = lParam
  
        IF @lpDs.itemID < 0 THEN
            EXIT SELECT
        END IF
  
        IF bTracking = %TRUE THEN EXIT FUNCTION
  
        rectFull = @lpDs.rcItem
        rc = rectFull
  
        IF nDivider = 0 THEN nDivider   = (rc.nRight - rc.nLeft)  \ 2
  
        rc.nleft   = nDivider
        rc2        = rectFull
        rc2.nright = rc.nleft - 1
        nIndex     = @lpDs.itemID
  
        IF  nIndex  > -1  THEN
   
            'draw two rectangles, one for each row column
            hBrush = CreateSolidBrush( RGB(192,192,192) )
            Call FillRect(@lpDs.hDC , rc2, hBrush )
            CALL DeleteObject(hBrush)
  
            Call DrawEdge(@lpDs.hDC , rc2, %EDGE_SUNKEN,%BF_BOTTOMRIGHT )
            Call DrawEdge(@lpDs.hDC , rc,  %EDGE_SUNKEN,%BF_BOTTOM )
  
            Call SetBkMode( @lpDs.hDC , %TRANSPARENT )
  
            rc2.nleft   = rc2.nleft   + 3
            rc2.ntop    = rc2.ntop    + 3
            rc2.nright  = rc2.nright  - 3
            rc2.nbottom = rc2.nbottom + 3
  
            'write the Property Name in the first rectangle, left side
            Call DrawText( @lpDs.hDC , pItem(nIndex).propName, _
                           LEN(pItem(nIndex).propName), _
                           rc2, %DT_LEFT OR %DT_SINGLELINE )
  
            rc.nleft   = rc.nleft   + 3
            rc.ntop    = rc.ntop    + 3
            rc.nright  = rc.nright  + 3
            rc.nbottom = rc.nbottom + 3
  
            'write the initial property value in the second rectangle, right side
            Call DrawText(@lpDs.hDC , pItem(nIndex).curValue, _
                          LEN(pItem(nIndex).curValue), _
                          rc, %DT_LEFT OR %DT_SINGLELINE )
        END IF
  
        '<insert here>  Add some kind of item focus rect
  
        FUNCTION = %TRUE
        EXIT FUNCTION
  

    CASE %WM_COMMAND
  
        'ListBox control notifications...
        SELECT CASE LOWRD(wParam)
               CASE %IDC_LISTBOX
                    SELECT CASE HIWRD(wParam)
                           CASE %LBN_SELCHANGE
                                Call OnSelChange()
                    END SELECT
        END SELECT
  
        '---
        CASE %WM_DESTROY
  
            If ghFont <> 0 Then Call DeleteObject( ghFont )
            If lpOldListProc <> 0 Then Call SetWindowLong( ghList,%GWL_WNDPROC,lpOldListProc )
            Call PostQuitMessage( 0 )
  
    END SELECT
  
    FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
END FUNCTION

  
'----------------------------------------------------------------------------
' LBN_SELCHANGE:
'----------------------------------------------------------------------------
SUB OnSelChange()
  
    LOCAL rc AS RECT
    LOCAL lBoxSelText AS STRING
  
    curSel = SendMessage( ghList, %LB_GETCURSEL, 0, 0 )
    Call SendMessage( ghList, %LB_GETITEMRECT, curSel, VarPtr(rc) )
  
    rc.nleft = nDivider
  
    IF ghCombo  <> 0 THEN Call ShowWindow( ghCombo,  %SW_HIDE )
    IF ghButton <> 0 THEN Call ShowWindow( ghButton, %SW_HIDE )
    IF ghEdit   <> 0 THEN Call ShowWindow( ghEdit,   %SW_HIDE )
  
    IF pItem(curSel).nItemType = %PIT_COMBO  THEN
  
        'display the combo box and move it to the new location
        nLastBox = 0
  
        IF ghCombo <> 0 THEN
           Call MoveWindow( ghCombo,rc.nleft-1,rc.ntop-2,rc.nright+2-rc.nleft,rc.nbottom+100,1 )
        END IF
  
        'add the choices for this particular property
        cmbItems$   = pItem(curSel).cmbItems
        lBoxSelText = pItem(curSel).curValue
  
        Call SendMessage( ghCombo,%CB_RESETCONTENT, 0,0 )
  
        delimiter$ = "|"
        nCount& = Tally(cmbItems$,delimiter$)
  
        For i& = 1 To nCount&
            dataItem$ = Parse$(cmbItems$,delimiter$,i&)
            'add each string to the ComboBox
            Call SendMessage(ghCombo, %CB_ADDSTRING, i&-1, StrPtr(dataItem$) )
        Next
  
        Call ShowWindow( ghCombo,%SW_SHOW )
        Call SetFocus( ghCombo )
        'Call SetFocus( ghList )
  
        'jump to the property's current value in the combo box
        j& = SendMessage(ghCombo,%CB_FINDSTRINGEXACT,0,StrPtr(lBoxSelText) )
        IF  j& <> %CB_ERR  THEN
            Call SendMessage( ghCombo,%CB_SETCURSEL,j&,0 )
        ELSE
            'there is no current value, so default to first in list
            Call SendMessage( ghCombo,%CB_SETCURSEL,0,0 )
        END IF
  
    ELSEIF pItem(curSel).nItemType = %PIT_EDIT  THEN
  
        'display edit box
        nLastBox   = 1
        prevSel    = curSel
        rc.nbottom = rc.nbottom - 3
  
        IF ghEdit <> 0 THEN
           Call MoveWindow( ghEdit,rc.nleft+1,rc.ntop+3,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
        END IF
  
        lBoxSelText = pItem(curSel).curValue
  
        Call ShowWindow( ghEdit, %SW_SHOW )
        Call SetFocus( ghEdit )
        'Call SetFocus( ghList )
  
        'set the text in the edit box to the property's current value
        Call SendMessage(ghEdit, %WM_SETTEXT, 0, StrPtr(lBoxSelText) )
  
    ELSE
        'displays a button if the property is a Color/File/Font chooser
        nLastBox = 2
        prevSel  = curSel
  
        nWidth& = rc.nright - rc.nleft
  
        IF  nWidth& > 25  THEN
            rc.nleft   = rc.nright  - 25
        END IF
  
        rc.nbottom = rc.nbottom - 3
  
        IF ghButton <> 0  THEN
           Call MoveWindow( ghButton,rc.nleft,rc.ntop,rc.nRight -rc.nleft, rc.nBottom -rc.ntop, 1 )
        END IF
  
        Call ShowWindow( ghButton, %SW_SHOW )
        Call SetFocus( ghButton )
        'Call SetFocus( ghList )
        '---
  
    END IF
  
END SUB
  

'----------------------------------------------------------------------------
' BN_CLICKED:
'----------------------------------------------------------------------------
SUB OnButtonClicked()
  
     LOCAL initClr        AS DWORD
     LOCAL currClr        AS ASCIIZ*255
     LOCAL clrStr         AS ASCIIZ*255
     LOCAL ColorSpec      AS CHOOSECOLORAPI
     LOCAL lResult        AS LONG
     LOCAL lCounter       AS LONG
     LOCAL lCustomColor() AS LONG

  
    'display the appropriate common dialog depending on what type
    'of chooser is associated with the property
  
    'First check for the Choose Color dialog...
    IF pItem(curSel).nItemType = %PIT_COLOR  THEN
  
        currClr = pItem(curSel).curValue
  
        IF  currClr > "" THEN
  
            'parse the property's current color value
            d$  = ","
            currClr = LTRIM$(currClr,"RGB(")
            currClr = RTRIM$(currClr,")")
            rv%     = VAL(Parse$(currClr,d$,1))
            gv%     = VAL(Parse$(currClr,d$,2))
            bv%     = VAL(Parse$(currClr,d$,3))
  
            initClr = RGB(rv%,gv%,bv%)
        ELSE
            'use a default instead
            initClr = RGB( 255,128,128 )
        END IF
  
        ColorSpec.lStructSize  = LEN(ColorSpec)
        ColorSpec.hwndOwner    = ghList
        ColorSpec.lpCustColors = VARPTR(cColor(0))
        ColorSpec.rgbResult    = initClr
        ColorSpec.Flags        = ColorSpec.Flags OR %CC_RGBINIT
  
        lResult = ChooseColor(ColorSpec)
  
        IF lResult = 0 THEN 'check if user cancelled dialog ?
           EXIT SUB
        ELSE
  
            'selClr = ColorSpec.rgbResult
            clrStr = HEX$(ColorSpec.rgbResult,6)
  
            'Use Fomrat here, STR$ adds a leading space I don't want
            rv$ = FORMAT$(VAL("&H"+MID$(clrStr, 1,2)),",")
            gv$ = FORMAT$(VAL("&H"+MID$(clrStr, 3,2)),",") + ","
            bv$ = FORMAT$(VAL("&H"+MID$(clrStr, 5,2)),",") + ","
  
            'Note order of RGB, COLORREF 0x00bbggrr
            clrStr = "RGB("+bv$+gv$+rv$+")"
            pItem(curSel).curValue = clrStr
  
            'Call ShowWindow( ghButton,%SW_HIDE )
  
            Call InvalidateRect( ghList,ByVal %NULL,1)
            Call UpdateWindow ( ghList )
         END IF
  
    'Next check for the Open File Dialog...
    ELSEIF  pItem(curSel).nItemType = %PIT_FILE THEN
  
        LOCAL SelectedFile AS ASCIIZ*255
        LOCAL zTxt  AS ASCIIZ * 255
  
        zTxt = "All pictures  (*.bmp,*.ico)|*.BMP;*.ICO|"
        zTxt = zTxt & "Bitmap (*.bmp)|*.BMP|"
        ZTxt = zTxt & "Icon   (*.ico)|*.ICO|"
  
        currPath$ = pItem(curSel).curValue
        If currPath$ = "none" Then
           fName$ = ""
        Else
           fName$ = currPath$
        End IF
  
        'use simple Open dialog for demo...
        tmp& = OpenFileDialog(ghMain,"Select File:",fName$,CURDIR$,zTxt,"BMP", _
                              %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES)
        IF tmp& Then
            pItem(curSel).curValue = fName$
            Call InvalidateRect( ghList,ByVal %NULL,1)
            Call UpdateWindow ( ghList )
        END IF
  
'    END IF '<remove later>
  
    'Last, check for the ChooseFont() dialog...
    ELSEIF pItem(curSel).nItemType = %PIT_FONT  THEN
  
        DIM cf AS CHOOSEFONTAPI
        DIM lfFont AS LOGFONT
        cf.lStructSize = SIZEOF(cf)
        cf.hWndOwner   = ghMain
        cf.lpLogFont   = VarPtr(lfFont)
        cf.Flags       = %CF_EFFECTS OR %CF_SCREENFONTS
  
        lResult = ChooseFont(cf)
  
        IF lResult = 0 THEN 'check if user cancelled dialog ?
           EXIT SUB
        ELSE
            faceName$   = lfFont.lfFaceName
  
            'Call ShowWindow( ghButton,%SW_HIDE )
  
            'ToDo: Not included in orgional C++, get the Font height...
            pItem(curSel).curValue = faceName$
  
            Call InvalidateRect( ghList,ByVal %NULL,1)
            Call UpdateWindow ( ghList )
  
        END IF
  
    END IF
  
END SUB

  
'-------------------------------------------------------------------------
' Create a Font:
'-------------------------------------------------------------------------
FUNCTION MakeFont(BYVAL Font AS STRING, BYVAL PointSize AS LONG) AS LONG
  
    LOCAL hDC AS LONG, CyPixels AS LONG
    hDC = GetDC(%HWND_DESKTOP)
    CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
    ReleaseDC %HWND_DESKTOP, hDC
    PointSize = (PointSize * CyPixels) \ 72
  
    FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
    %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
    %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY Font)
  
END FUNCTION                                                                                                                                                                                                                                                                                                                                                                                                                                        
  
'-------------------------------------------------------------------------
'' SubClassed ListBox Control Procedure:
'
'-------------------------------------------------------------------------
FUNCTION ListBoxProc(BYVAL hWnd as LONG, BYVAL wMsg as LONG, _
                     BYVAL wParam as LONG, BYVAL lParam as LONG) AS LONG
  
    LOCAL pt AS POINTAPI
  

    SELECT CASE wMsg
  
        'Catch the Combo,Edit,Button child control notifications here...
        CASE %WM_COMMAND
        SELECT CASE LOWRD(wParam)
               CASE %IDC_COMBO
                    SELECT CASE HIWRD(wParam)
                           CASE %CBN_SELCHANGE
                                LOCAL selStr AS ASCIIZ*255
                                IF ghCombo <> 0  THEN
                                   idx& = SendMessage( ghCombo, %CB_GETCURSEL ,0 ,0 )
                                   Call SendMessage( ghCombo, %CB_GETLBTEXT, idx& , VarPtr(selStr) )
                                   pItem(curSel).curValue = selStr
                                END IF
                    END SELECT
  
               CASE %IDC_EDIT
                    SELECT CASE HIWRD(wParam)
                           CASE %EN_CHANGE
                               LOCAL newStr AS ASCIIZ*255
                               tLen&  = SendMessage(ghEdit, %WM_GETTEXTLENGTH, 0, 0) + 1
                               newStr = SPACE$(tLen&)
                               CALL SendMessage(ghEdit, %WM_GETTEXT, tLen&, VarPtr(newStr))
                               pItem(curSel).curValue = newStr
                    END SELECT
  
               CASE %IDC_BUTTON
                    SELECT CASE HIWRD(wParam)
                           CASE %BN_CLICKED
                               Call OnButtonClicked()
                    END SELECT

        END SELECT
  

        CASE %WM_LBUTTONDOWN
            IF ghCombo  <> 0 THEN Call ShowWindow( ghCombo,  %SW_HIDE )
            IF ghEdit   <> 0 THEN Call ShowWindow( ghEdit,   %SW_HIDE )
            IF ghButton <> 0 THEN Call ShowWindow( ghButton, %SW_HIDE )
 
            '-----------------------[ Splitter ]-----------------------
            pt.x = LoWrd(lParam)
            pt.y = HiWrd(lParam)
 
            IF ((pt.x >= nDivider-5) AND (pt.x <= nDivider+5)) THEN
                'if mouse clicked on divider line, then start resizing
                Call SetCursor(hCursorSize)
 
                Local rc AS RECT
                Call GetWindowRect( hWnd ,rc )
                rc.nleft  = rc.nleft  +10
                rc.nright = rc.nright -20
 
                'do not let mouse leave the list box boundary
                Call ClipCursor( rc )
                Call GetClientRect( hWnd ,rc )
                bTracking = %TRUE
 
                nDivTop   = rc.ntop
                nDivBtm   = rc.nbottom
                nOldDivX  = pt.x
 
                Call InvertLine( nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
 
                'capture the mouse
                Call SetCapture(hWnd)
 
            END IF
 

        CASE %WM_MOUSEMOVE
            pt.x = LoWrd(lParam)
            pt.y = HiWrd(lParam)
 
            'move divider line to the mouse position
            'if columns are currently being resized
            IF bTracking = %TRUE  THEN
 
                'remove old divider line
                Call InvertLine( nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
 
                'draw new divider line
                Call InvertLine( pt.x ,nDivTop ,pt.x ,nDivBtm )
 
                nOldDivX = pt.x
 
            ELSE
  
                'set the cursor to a sizing cursor if
                'the cursor is over the row divider
                IF (pt.x >= nDivider-5) AND (pt.x <= nDivider+5) THEN
                   Call SetCursor(hCursorSize)
                END IF
   
           END IF
  

        CASE %WM_LBUTTONUP
            pt.x = LoWrd(lParam)
            pt.y = HiWrd(lParam)
  
            'if columns were being resized then this indicates
            'that mouse is up so resizing is done.  Need to redraw
            'columns to reflect their new widths.
            IF bTracking = %TRUE THEN
  
                bTracking = %FALSE
                Call ReleaseCapture()
                Call ClipCursor( ByVal %NULL )
  
                Call InvertLine( pt.x ,nDivTop ,pt.x ,nDivBtm )

  
                'set the divider position to the new value
                nDivider = pt.x
  
                'Self paint the ListBox control...
                Call InvalidateRect(hWnd ,ByVal %NULL, 1)
                Call UpdateWindow(hWnd)
  
            END IF
  
           CASE %WM_CAPTURECHANGED
                IF lParam <> ghList THEN
                    IF bTracking = %TRUE THEN
                        bTracking = %FALSE
                        Call ReleaseCapture()
                        Call ClipCursor( ByVal %NULL )
                        Call InvalidateRect(ghList ,ByVal %NULL, 1)
                        Call UpdateWindow(ghList)
                    END IF
                END IF
           '---------------------[ end of splitter ]------------------
  
    END SELECT
  
  FUNCTION = CallWindowProc( ByVal lpOldListProc,hWnd,wMsg,wParam,lParam )
  
END FUNCTION
  

'--------------------------------------------------------------------------
' InvertLine()
'--------------------------------------------------------------------------
SUB InvertLine( ByVal xleft1 AS INTEGER ,ByVal yFrom AS INTEGER, _
                ByVal xleft2 AS INTEGER ,ByVal yTo AS INTEGER )

  
    LOCAL hDC       AS LONG
    LOCAL nDrawMode AS LONG
    LOCAL oldpt     AS POINTAPI
  
    '*Get DC of ListBox
    hDC = GetDC(ghList)
  
    '*Use the default Pen color and style...
  
    '*Set the GDI foreground mix mode
    nDrawMode = SetROP2(hDC, %R2_NOT)
  
    '*Draw the Line
    Call MoveToEx( hDC ,xLeft1 ,yFrom ,oldpt)
    Call LineTo( hDC ,xLeft2 ,yTo)
  
    '*Restore DC
    Call SetROP2(hDC, nDrawMode)
    Call ReleaseDC(ghList, hDC)
  
END SUB
  
'--------------------------------------------------------------------------
' User Designed Custom Control Properties:
'
'--------------------------------------------------------------------------
SUB InitializePropertyItems()
  
    pItem(0).propName  =  "ToolTip Text"
    pItem(0).curValue  =  "Litte Red Riding Hood..."
    pItem(0).nItemType =  %PIT_EDIT
    pItem(0).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(0).propName))
  
    pItem(1).propName  =  "Enabled"
    pItem(1).curValue  =  "true"
    pItem(1).nItemType =  %PIT_COMBO
    pItem(1).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(1).propName))
  
    pItem(2).propName  =  "Visible"
    pItem(2).curValue  =  "true"
    pItem(2).nItemType =  %PIT_COMBO
    pItem(2).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(2).propName))
  
    pItem(3).propName  =  "Fore. Color"
    pItem(3).curValue  =  "RGB(255,255,0)"
    pItem(3).nItemType =  %PIT_COLOR
    pItem(3).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(3).propName))
  
    pItem(4).propName  =  "Back. Color"
    pItem(4).curValue  =  "RGB(255,0,128)"
    pItem(4).nItemType =  %PIT_COLOR
    pItem(4).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(4).propName))
  
    pItem(5).propName  =  "Opaque"
    pItem(5).curValue  =  "false"
    pItem(5).nItemType =  %PIT_COMBO
    pItem(5).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(5).propName))
  
    pItem(6).propName  =  "Auto. Scroll"
    pItem(6).curValue  =  "true"
    pItem(6).nItemType =  %PIT_COMBO
    pItem(6).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(6).propName))
  
    pItem(7).propName  =  "Double Buffered"
    pItem(7).curValue  =  "true"
    pItem(7).nItemType =  %PIT_COMBO
    pItem(7).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(7).propName))
  
    pItem(8).propName  =  "Font"
    pItem(8).curValue  =  "MS San Sarif"
    pItem(8).nItemType =  %PIT_FONT
    pItem(8).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(8).propName))
  
    pItem(9).propName  = "Text"
    pItem(9).curValue  =  "Big Bad Wolf!"
    pItem(9).nItemType =  %PIT_EDIT
    pItem(9).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(9).propName))
  
    pItem(10).propName  =  "Horiz. Align"
    pItem(10).curValue  =  "CENTER"
    pItem(10).nItemType =  %PIT_COMBO
    pItem(10).cmbItems  =  "CENTER|LEFT|RIGHT|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(10).propName))
  
    pItem(11).propName  =  "Vert. Align"
    pItem(11).curValue  =  "CENTER"
    pItem(11).nItemType =  %PIT_COMBO
    pItem(11).cmbItems  =  "CENTER|TOP|BOTTOM|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(11).propName))
  
    pItem(12).propName  =  "Bmp ,Icon"
    pItem(12).curValue  =  "none"
    pItem(12).nItemType =  %PIT_FILE
    pItem(12).cmbItems  =  ""
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(12).propName))
  
    pItem(13).propName  =  "Border Painted"
    pItem(13).curValue  =  "false"
    pItem(13).nItemType =  %PIT_COMBO
    pItem(13).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(13).propName))
  
    pItem(14).propName  =  "Fill Content Area"
    pItem(14).curValue  =  "true"
    pItem(14).nItemType =  %PIT_COMBO
    pItem(14).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(14).propName))
  
    pItem(15).propName  = "Focus Painted"
    pItem(15).curValue  =  "true"
    pItem(15).nItemType =  %PIT_COMBO
    pItem(15).cmbItems  =  "true|false|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(15).propName))
  
    pItem(16).propName  =  "Horiz. Text Pos."
    pItem(16).curValue  =  "RIGHT"
    pItem(16).nItemType =  %PIT_COMBO
    pItem(16).cmbItems  =  "RIGHT|LEFT|CENTER|LEADING|TRAILING|"
    Call SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(16).propName))
  
END SUB
                                                                                                                                                                                                                                                                 
'--------------------------------------------------------------------------
' Load 16 Custom colors up for our ChooseColor() Dialog
'--------------------------------------------------------------------------
SUB InitializeCustomColors()
  
  LOCAL lCounter AS LONG
  
  DIM cColor(0:15)
  
  'load your custom colors...
  RANDOMIZE TIMER
  FOR lCounter = 0 TO 15
    'example colors,
    cColor(lCounter) = RND(0,16777215)
  NEXT
  
END SUB
                                                                                                                                                                                                                                                                 
'--------------------------------------------------------------------------
' We don't have one yet, so just fill in with a place holder
'--------------------------------------------------------------------------
SUB InitializeUserCustomControl()
  
   ghUCC = CreateWindowEx(%WS_EX_CLIENTEDGE,"STATIC", _
                          "Explore Your Custom Designed Control       Here...", %WS_CHILD OR %WS_VISIBLE _
                          OR %WS_BORDER OR %WS_CLIPSIBLINGS OR %SS_NOTIFY _
                          OR %SS_CENTER, _
                          380, _
                          60, _
                          200, _
                          200, _
                          ghMain, _
                          %IDC_UCC, _
                          ghInst, _
                          BYVAL %NULL)

  
END SUB

    [This message has been edited by Jules Marchildon (edited February 06, 2001).]
    Tags: None
    #2
    version which compiles under PB 8.04

    not tested but does plausible stuff & compiles.

    Code:
    '--------------------------------------------------------------------------------------------
' Module:  ListProp.Bas
' Desc:    OwnerDraw ListBox
' Purpose: For exploring "User Desinged" custom control properties <adding later>
' Date:    Jan. 23, 2001
' Name:    By Jules Marchildon  <[email protected]>
'--------------------------------------------------------------------------------------------

#COMPILE EXE
#INCLUDE "WIN32API.INC"
#INCLUDE "COMDLG32.INC"

'---
DECLARE SUB InitializePropertyItems()
DECLARE SUB InitializeCustomColors()
DECLARE SUB InitializeUserCustomControl()
DECLARE SUB OnSelchange()
DECLARE SUB OnButtonClicked()
DECLARE SUB InvertLine( BYVAL xleft1 AS INTEGER ,BYVAL yFrom AS INTEGER ,BYVAL xleft2 AS INTEGER ,BYVAL yTo AS INTEGER)
DECLARE FUNCTION MakeFont(BYVAL sFont AS STRING, BYVAL PointSize AS LONG) AS LONG

'---
GLOBAL ghInst   AS LONG
GLOBAL ghMain   AS LONG
GLOBAL ghList   AS LONG
GLOBAL ghButton AS LONG
GLOBAL ghCombo  AS LONG
GLOBAL ghEdit   AS LONG
GLOBAL ghFont   AS LONG
GLOBAL ghUCC    AS LONG

GLOBAL lpOldListProc  AS LONG

GLOBAL curSel         AS INTEGER
GLOBAL prevSel        AS INTEGER
GLOBAL nDivider       AS INTEGER
GLOBAL nDivTop        AS INTEGER
GLOBAL nDivBtm        AS INTEGER
GLOBAL nOldDivX       AS INTEGER
GLOBAL nLastBox       AS INTEGER
GLOBAL bTracking      AS LONG
GLOBAL bDivIsSet      AS INTEGER

GLOBAL hCursorArrow   AS LONG
GLOBAL hCursorSize    AS LONG
GLOBAL cColor()       AS LONG


'---
TYPE PROPERTYITEM
  propName  AS ASCIIZ*225
  curValue  AS ASCIIZ*255
  nItemType AS INTEGER
  cmbItems  AS ASCIIZ*255
END TYPE

GLOBAL pItem()  AS PROPERTYITEM 'details for User designed custom control

'---
%IDC_LISTBOX = 1000
%IDC_COMBO   = 1001
%IDC_BUTTON  = 1002
%IDC_EDIT    = 1003
%IDC_UCC     = 1004

'PIT = property item type, Button is default
%PIT_COMBO   = 0
%PIT_EDIT    = 1
%PIT_COLOR   = 2
%PIT_FONT    = 3
%PIT_FILE    = 4

'-------------------------------------------------------------
' WinMain:
'
'
'-------------------------------------------------------------
FUNCTION WINMAIN (BYVAL hInstance     AS LONG, _
                  BYVAL hPrevInstance AS LONG, _
                  BYVAL lpCmdLine           AS ASCIIZ PTR, _
                  BYVAL iCmdShow      AS LONG) AS LONG

    LOCAL Msg       AS tagMsg
    LOCAL wndclss  AS WndClassEx
    LOCAL hWnd, result      AS LONG
    LOCAL rct       AS RECT
    LOCAL szpgmname AS ASCIIZ * 20

    szpgmname = "PROPLIST"

    wndclss.cbSize        = SIZEOF(WndClss)
    wndclss.style         = %CS_HREDRAW OR %CS_VREDRAW OR %CS_DBLCLKS
    wndclss.lpfnWndProc   = CODEPTR( MainWndProc )
    wndclss.cbClsExtra    = 0
    wndclss.cbWndExtra    = 0
    wndclss.hInstance     = hInstance
    wndclss.hIcon         = LoadIcon( hInstance, "MAINICON" )
    wndclss.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )
    wndclss.hbrBackground = GetStockObject( %LTGRAY_BRUSH )
    wndclss.lpszMenuName  = %NULL
    wndclss.lpszClassName = VARPTR(szpgmname)
    wndclss.hIconSm       = LoadIcon(hInstance, BYVAL %IDI_APPLICATION)

    result = RegisterClassEx (wndclss)
    
    IF result = 0 THEN
        result = getlasterror
        ERR = result
        ?ERROR$
    END IF
    
    ghInst = hInstance

    style& = %WS_OVERLAPPED OR _
             %WS_CAPTION OR _
             %WS_SYSMENU OR _ '%WS_SIZEBOX OR _
             %WS_visible 'MINIMIZEBOX

    'create the main window (my screen LCD,1024x768)
    hWnd = CreateWindowEx(0, _
                szpgmname, _
                "Control Properties:", _
                style&, _
                210, 110, 650, 350, _
                %HWND_DESKTOP, _
                %NULL, _
                hInstance, _
                BYVAL %NULL)

    ' fail if window is not created
    IF ISFALSE hWnd THEN
      FUNCTION = %FALSE
      EXIT FUNCTION
    END IF
    ' Activate window
    ShowWindow hWnd, %SW_SHOW
    ' Paint client area
    UpdateWindow hWnd
    WHILE ISTRUE GetMessage(msg, BYVAL %NULL, 0, 0)
        IF ISFALSE IsDialogMessage(hWnd, msg) THEN
            TranslateMessage msg
            DispatchMessage msg
        END IF
    WEND
    FUNCTION = msg.wParam

END FUNCTION


'------------------------------------------------------------------------
'
' MainWndProc()
'
'------------------------------------------------------------------------
FUNCTION MainWndProc(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG, _
                     BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG

    LOCAL lpDs      AS DRAWITEMSTRUCT PTR
    LOCAL lpMs      AS MEASUREITEMSTRUCT PTR
    LOCAL hBrush    AS LONG

    LOCAL rc        AS RECT
    LOCAL rectFull  AS RECT
    LOCAL rc2       AS RECT
    LOCAL nIndex    AS INTEGER


    ghMain = hWnd

'---
SELECT CASE wMsg
    CASE %WM_CREATE

            DIM pItem(0:16) AS PROPERTYITEM

            bTracking = %FALSE
            nDivider  = 0
            bDivIsSet = %FALSE
            curSel    = 1

            hCursorArrow =  LoadCursor( %NULL, BYVAL %IDC_ARROW )
            hCursorSize  =  LoadCursor( %NULL, BYVAL %IDC_SIZEWE )

            ghFont = MakeFont("MS San Sarif", 9)

            '  Create the OwnerDraw List box for our control properties...
            ghList   = CreateWindowEx(%WS_EX_CLIENTEDGE, "LISTBOX", "", _
                                     %WS_CHILD OR %WS_VISIBLE OR _
                                     %WS_TABSTOP OR %WS_BORDER OR _
                                     %LBS_NOINTEGRALHEIGHT OR _
                                     %LBS_HASSTRINGS OR _
                                     %LBS_OWNERDRAWFIXED OR _
                                     %LBS_NOTIFY OR _
                                     %WS_VSCROLL, _
                                     10,10,300,306, _
                                     ghMain, _
                                     %IDC_LISTBOX, _
                                     ghInst, BYVAL %NULL)

            'SubClass the ListBox
            lpOldListProc = SetWindowLong( ghList,%GWL_WNDPROC,BYVAL CODEPTR(ListBoxProc) )

            CALL SendMessage( ghList, %WM_SETFONT, ghFont, 0 )

            '  Create the controls that will need to edit the Properties with.
            '  They are all hidden for now and resized later.
            ghButton = CreateWindowEx(0,"BUTTON","...", _
                                      %WS_CHILD OR %WS_CLIPSIBLINGS OR _
                                      %BS_PUSHBUTTON, _
                                      0,0,8,12, _
                                      ghList, _
                                      %IDC_BUTTON,   _
                                      ghInst, BYVAL %NULL)

            CALL SendMessage( ghButton, %WM_SETFONT, ghFont, 0 )

            ghCombo  = CreateWindowEx(0,"COMBOBOX", "", _
                                      %WS_CHILD OR _
                                      %CBS_DROPDOWNLIST _
                                      OR %CBS_NOINTEGRALHEIGHT, _
                                      0,0,10,100, _
                                      ghList, _
                                      %IDC_COMBO, _
                                      ghInst, BYVAL %NULL)

            CALL SendMessage( ghCombo, %WM_SETFONT, ghFont, 0 )

            ghEdit   = CreateWindowEx(0,"EDIT", "True", _
                                      %WS_CHILD OR %WS_CLIPSIBLINGS OR _
                                      %ES_LEFT OR %ES_AUTOHSCROLL OR %WS_BORDER, _
                                      0,0,10,20, _
                                      ghList, _
                                      %IDC_EDIT,_
                                      ghInst, BYVAL %NULL)

            CALL SendMessage( ghEdit, %WM_SETFONT, ghFont, 0 )
            '-------------------------------------------------------------------

            '  This call must be done AFTER the listbox has been created!
            CALL InitializePropertyItems()
            CALL InitializeCustomColors()

            '  Add our User designed Custom Control
            CALL InitializeUserCustomControl()

            FUNCTION = %TRUE
            EXIT FUNCTION


    CASE %WM_MEASUREITEM

         lpMs = lParam
         'arbitrary number for height
         @lpMs.itemHeight = 20

         FUNCTION = %TRUE
         EXIT FUNCTION


    CASE %WM_DRAWITEM

        lpDs = lParam

        IF @lpDs.itemID < 0 THEN
            EXIT SELECT
        END IF

        IF bTracking = %TRUE THEN EXIT FUNCTION

        rectFull = @lpDs.rcItem
        rc = rectFull

        IF nDivider = 0 THEN nDivider   = (rc.nRight - rc.nLeft)  \ 2

        rc.nleft   = nDivider
        rc2        = rectFull
        rc2.nright = rc.nleft - 1
        nIndex     = @lpDs.itemID

        IF  nIndex  > -1  THEN

            'draw two rectangles, one for each row column
            hBrush = CreateSolidBrush( RGB(192,192,192) )
            CALL FillRect(@lpDs.hDC , rc2, hBrush )
            CALL DeleteObject(hBrush)

            CALL DrawEdge(@lpDs.hDC , rc2, %EDGE_SUNKEN,%BF_BOTTOMRIGHT )
            CALL DrawEdge(@lpDs.hDC , rc,  %EDGE_SUNKEN,%BF_BOTTOM )

            CALL SetBkMode( @lpDs.hDC , %TRANSPARENT )

            rc2.nleft   = rc2.nleft   + 3
            rc2.ntop    = rc2.ntop    + 3
            rc2.nright  = rc2.nright  - 3
            rc2.nbottom = rc2.nbottom + 3

            'write the Property Name in the first rectangle, left side
            CALL DrawText( @lpDs.hDC , pItem(nIndex).propName, _
                           LEN(pItem(nIndex).propName), _
                           rc2, %DT_LEFT OR %DT_SINGLELINE )

            rc.nleft   = rc.nleft   + 3
            rc.ntop    = rc.ntop    + 3
            rc.nright  = rc.nright  + 3
            rc.nbottom = rc.nbottom + 3

            'write the initial property value in the second rectangle, right side
            CALL DrawText(@lpDs.hDC , pItem(nIndex).curValue, _
                          LEN(pItem(nIndex).curValue), _
                          rc, %DT_LEFT OR %DT_SINGLELINE )
        END IF

        '<insert here>  Add some kind of item focus rect

        FUNCTION = %TRUE
        EXIT FUNCTION


    CASE %WM_COMMAND

        'ListBox control notifications...
        SELECT CASE LOWRD(wParam)
               CASE %IDC_LISTBOX
                    SELECT CASE HIWRD(wParam)
                           CASE %LBN_SELCHANGE
                                CALL OnSelChange()
                    END SELECT
        END SELECT

        '---
        CASE %WM_DESTROY

            IF ghFont <> 0 THEN CALL DeleteObject( ghFont )
            IF lpOldListProc <> 0 THEN CALL SetWindowLong( ghList,%GWL_WNDPROC,lpOldListProc )
            CALL PostQuitMessage( 0 )

    END SELECT

    FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
END FUNCTION


'----------------------------------------------------------------------------
' LBN_SELCHANGE:
'----------------------------------------------------------------------------
SUB OnSelChange()

    LOCAL rc AS RECT
    LOCAL lBoxSelText AS STRING

    curSel = SendMessage( ghList, %LB_GETCURSEL, 0, 0 )
    CALL SendMessage( ghList, %LB_GETITEMRECT, curSel, VARPTR(rc) )

    rc.nleft = nDivider

    IF ghCombo  <> 0 THEN CALL ShowWindow( ghCombo,  %SW_HIDE )
    IF ghButton <> 0 THEN CALL ShowWindow( ghButton, %SW_HIDE )
    IF ghEdit   <> 0 THEN CALL ShowWindow( ghEdit,   %SW_HIDE )

    IF pItem(curSel).nItemType = %PIT_COMBO  THEN

        'display the combo box and move it to the new location
        nLastBox = 0

        IF ghCombo <> 0 THEN
           CALL MoveWindow( ghCombo,rc.nleft-1,rc.ntop-2,rc.nright+2-rc.nleft,rc.nbottom+100,1 )
        END IF

        'add the choices for this particular property
        cmbItems$   = pItem(curSel).cmbItems
        lBoxSelText = pItem(curSel).curValue

        CALL SendMessage( ghCombo,%CB_RESETCONTENT, 0,0 )

        delimiter$ = "|"
        nCount& = TALLY(cmbItems$,delimiter$)

        FOR i& = 1 TO nCount&
            dataItem$ = PARSE$(cmbItems$,delimiter$,i&)
            'add each string to the ComboBox
            CALL SendMessage(ghCombo, %CB_ADDSTRING, i&-1, STRPTR(dataItem$) )
        NEXT

        CALL ShowWindow( ghCombo,%SW_SHOW )
        CALL SetFocus( ghCombo )
        'Call SetFocus( ghList )

        'jump to the property's current value in the combo box
        j& = SendMessage(ghCombo,%CB_FINDSTRINGEXACT,0,STRPTR(lBoxSelText) )
        IF  j& <> %CB_ERR  THEN
            CALL SendMessage( ghCombo,%CB_SETCURSEL,j&,0 )
        ELSE
            'there is no current value, so default to first in list
            CALL SendMessage( ghCombo,%CB_SETCURSEL,0,0 )
        END IF

    ELSEIF pItem(curSel).nItemType = %PIT_EDIT  THEN

        'display edit box
        nLastBox   = 1
        prevSel    = curSel
        rc.nbottom = rc.nbottom - 3

        IF ghEdit <> 0 THEN
           CALL MoveWindow( ghEdit,rc.nleft+1,rc.ntop+3,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
        END IF

        lBoxSelText = pItem(curSel).curValue

        CALL ShowWindow( ghEdit, %SW_SHOW )
        CALL SetFocus( ghEdit )
        'Call SetFocus( ghList )

        'set the text in the edit box to the property's current value
        CALL SendMessage(ghEdit, %WM_SETTEXT, 0, STRPTR(lBoxSelText) )

    ELSE
        'displays a button if the property is a Color/File/Font chooser
        nLastBox = 2
        prevSel  = curSel

        nWidth& = rc.nright - rc.nleft

        IF  nWidth& > 25  THEN
            rc.nleft   = rc.nright  - 25
        END IF

        rc.nbottom = rc.nbottom - 3

        IF ghButton <> 0  THEN
           CALL MoveWindow( ghButton,rc.nleft,rc.ntop,rc.nRight -rc.nleft, rc.nBottom -rc.ntop, 1 )
        END IF

        CALL ShowWindow( ghButton, %SW_SHOW )
        CALL SetFocus( ghButton )
        'Call SetFocus( ghList )
        '---

    END IF

END SUB


'----------------------------------------------------------------------------
' BN_CLICKED:
'----------------------------------------------------------------------------
SUB OnButtonClicked()

     LOCAL initClr        AS DWORD
     LOCAL currClr        AS ASCIIZ*255
     LOCAL clrStr         AS ASCIIZ*255
     LOCAL ColorSpec      AS CHOOSECOLORAPI
     LOCAL lResult        AS LONG
     LOCAL lCounter       AS LONG
     LOCAL lCustomColor() AS LONG


    'display the appropriate common dialog depending on what type
    'of chooser is associated with the property

    'First check for the Choose Color dialog...
    IF pItem(curSel).nItemType = %PIT_COLOR  THEN

        currClr = pItem(curSel).curValue

        IF  currClr > "" THEN

            'parse the property's current color value
            d$  = ","
            currClr = LTRIM$(currClr,"RGB(")
            currClr = RTRIM$(currClr,")")
            rv%     = VAL(PARSE$(currClr,d$,1))
            gv%     = VAL(PARSE$(currClr,d$,2))
            bv%     = VAL(PARSE$(currClr,d$,3))

            initClr = RGB(rv%,gv%,bv%)
        ELSE
            'use a default instead
            initClr = RGB( 255,128,128 )
        END IF

        ColorSpec.lStructSize  = LEN(ColorSpec)
        ColorSpec.hwndOwner    = ghList
        ColorSpec.lpCustColors = VARPTR(cColor(0))
        ColorSpec.rgbResult    = initClr
        ColorSpec.Flags        = ColorSpec.Flags OR %CC_RGBINIT

        lResult = ChooseColor(ColorSpec)

        IF lResult = 0 THEN 'check if user cancelled dialog ?
           EXIT SUB
        ELSE

            'selClr = ColorSpec.rgbResult
            clrStr = HEX$(ColorSpec.rgbResult,6)

            'Use Fomrat here, STR$ adds a leading space I don't want
            rv$ = FORMAT$(VAL("&H"+MID$(clrStr, 1,2)),",")
            gv$ = FORMAT$(VAL("&H"+MID$(clrStr, 3,2)),",") + ","
            bv$ = FORMAT$(VAL("&H"+MID$(clrStr, 5,2)),",") + ","

            'Note order of RGB, COLORREF 0x00bbggrr
            clrStr = "RGB("+bv$+gv$+rv$+")"
            pItem(curSel).curValue = clrStr

            'Call ShowWindow( ghButton,%SW_HIDE )

            CALL InvalidateRect( ghList,BYVAL %NULL,1)
            CALL UpdateWindow ( ghList )
         END IF

    'Next check for the Open File Dialog...
    ELSEIF  pItem(curSel).nItemType = %PIT_FILE THEN

        LOCAL SelectedFile AS ASCIIZ*255
        LOCAL zTxt  AS ASCIIZ * 255

        zTxt = "All pictures  (*.bmp,*.ico)|*.BMP;*.ICO|"
        zTxt = zTxt & "Bitmap (*.bmp)|*.BMP|"
        ZTxt = zTxt & "Icon   (*.ico)|*.ICO|"

        currPath$ = pItem(curSel).curValue
        IF currPath$ = "none" THEN
           fName$ = ""
        ELSE
           fName$ = currPath$
        END IF

        'use simple Open dialog for demo...
        tmp& = OpenFileDialog(ghMain,"Select File:",fName$,CURDIR$,zTxt,"BMP", _
                              %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES)
        IF tmp& THEN
            pItem(curSel).curValue = fName$
            CALL InvalidateRect( ghList,BYVAL %NULL,1)
            CALL UpdateWindow ( ghList )
        END IF

'    END IF '<remove later>

    'Last, check for the ChooseFont() dialog...
    ELSEIF pItem(curSel).nItemType = %PIT_FONT  THEN

        DIM cf AS CHOOSEFONTAPI
        DIM lfFont AS LOGFONT
        cf.lStructSize = SIZEOF(cf)
        cf.hWndOwner   = ghMain
        cf.lpLogFont   = VARPTR(lfFont)
        cf.Flags       = %CF_EFFECTS OR %CF_SCREENFONTS

        lResult = ChooseFont(cf)

        IF lResult = 0 THEN 'check if user cancelled dialog ?
           EXIT SUB
        ELSE
            faceName$   = lfFont.lfFaceName

            'Call ShowWindow( ghButton,%SW_HIDE )

            'ToDo: Not included in orgional C++, get the Font height...
            pItem(curSel).curValue = faceName$

            CALL InvalidateRect( ghList,BYVAL %NULL,1)
            CALL UpdateWindow ( ghList )

        END IF

    END IF

END SUB


'-------------------------------------------------------------------------
' Create a Font:
'-------------------------------------------------------------------------
FUNCTION MakeFont(BYVAL sFont AS STRING, BYVAL PointSize AS LONG) AS LONG

    LOCAL hDC AS LONG, CyPixels AS LONG
    hDC = GetDC(%HWND_DESKTOP)
    CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
    ReleaseDC %HWND_DESKTOP, hDC
    PointSize = (PointSize * CyPixels) \ 72

    FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
    %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
    %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY sFont)

END FUNCTION


'-------------------------------------------------------------------------
'' SubClassed ListBox Control Procedure:
'
'-------------------------------------------------------------------------
FUNCTION ListBoxProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                     BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG

    LOCAL pt AS POINTAPI


    SELECT CASE wMsg

        'Catch the Combo,Edit,Button child control notifications here...
        CASE %WM_COMMAND
        SELECT CASE LOWRD(wParam)
               CASE %IDC_COMBO
                    SELECT CASE HIWRD(wParam)
                           CASE %CBN_SELCHANGE
                                LOCAL selStr AS ASCIIZ*255
                                IF ghCombo <> 0  THEN
                                   idx& = SendMessage( ghCombo, %CB_GETCURSEL ,0 ,0 )
                                   CALL SendMessage( ghCombo, %CB_GETLBTEXT, idx& , VARPTR(selStr) )
                                   pItem(curSel).curValue = selStr
                                END IF
                    END SELECT

               CASE %IDC_EDIT
                    SELECT CASE HIWRD(wParam)
                           CASE %EN_CHANGE
                               LOCAL newStr AS ASCIIZ*255
                               tLen&  = SendMessage(ghEdit, %WM_GETTEXTLENGTH, 0, 0) + 1
                               newStr = SPACE$(tLen&)
                               CALL SendMessage(ghEdit, %WM_GETTEXT, tLen&, VARPTR(newStr))
                               pItem(curSel).curValue = newStr
                    END SELECT

               CASE %IDC_BUTTON
                    SELECT CASE HIWRD(wParam)
                           CASE %BN_CLICKED
                               CALL OnButtonClicked()
                    END SELECT

        END SELECT


        CASE %WM_LBUTTONDOWN
            IF ghCombo  <> 0 THEN CALL ShowWindow( ghCombo,  %SW_HIDE )
            IF ghEdit   <> 0 THEN CALL ShowWindow( ghEdit,   %SW_HIDE )
            IF ghButton <> 0 THEN CALL ShowWindow( ghButton, %SW_HIDE )

            '-----------------------[ Splitter ]-----------------------
            pt.x = LOWRD(lParam)
            pt.y = HIWRD(lParam)

            IF ((pt.x >= nDivider-5) AND (pt.x <= nDivider+5)) THEN
                'if mouse clicked on divider line, then start resizing
                CALL SetCursor(hCursorSize)

                LOCAL rc AS RECT
                CALL GetWindowRect( hWnd ,rc )
                rc.nleft  = rc.nleft  +10
                rc.nright = rc.nright -20

                'do not let mouse leave the list box boundary
                CALL ClipCursor( rc )
                CALL GetClientRect( hWnd ,rc )
                bTracking = %TRUE

                nDivTop   = rc.ntop
                nDivBtm   = rc.nbottom
                nOldDivX  = pt.x

                CALL InvertLine( nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )

                'capture the mouse
                CALL SetCapture(hWnd)

            END IF


        CASE %WM_MOUSEMOVE
            pt.x = LOWRD(lParam)
            pt.y = HIWRD(lParam)

            'move divider line to the mouse position
            'if columns are currently being resized
            IF bTracking = %TRUE  THEN

                'remove old divider line
                CALL InvertLine( nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )

                'draw new divider line
                CALL InvertLine( pt.x ,nDivTop ,pt.x ,nDivBtm )

                nOldDivX = pt.x

            ELSE

                'set the cursor to a sizing cursor if
                'the cursor is over the row divider
                IF (pt.x >= nDivider-5) AND (pt.x <= nDivider+5) THEN
                   CALL SetCursor(hCursorSize)
                END IF

           END IF


        CASE %WM_LBUTTONUP
            pt.x = LOWRD(lParam)
            pt.y = HIWRD(lParam)

            'if columns were being resized then this indicates
            'that mouse is up so resizing is done.  Need to redraw
            'columns to reflect their new widths.
            IF bTracking = %TRUE THEN

                bTracking = %FALSE
                CALL ReleaseCapture()
                CALL ClipCursor( BYVAL %NULL )

                CALL InvertLine( pt.x ,nDivTop ,pt.x ,nDivBtm )


                'set the divider position to the new value
                nDivider = pt.x

                'Self paint the ListBox control...
                CALL InvalidateRect(hWnd ,BYVAL %NULL, 1)
                CALL UpdateWindow(hWnd)

            END IF

           CASE %WM_CAPTURECHANGED
                IF lParam <> ghList THEN
                    IF bTracking = %TRUE THEN
                        bTracking = %FALSE
                        CALL ReleaseCapture()
                        CALL ClipCursor( BYVAL %NULL )
                        CALL InvalidateRect(ghList ,BYVAL %NULL, 1)
                        CALL UpdateWindow(ghList)
                    END IF
                END IF
           '---------------------[ end of splitter ]------------------

    END SELECT

  FUNCTION = CallWindowProc( BYVAL lpOldListProc,hWnd,wMsg,wParam,lParam )

END FUNCTION


'--------------------------------------------------------------------------
' InvertLine()
'--------------------------------------------------------------------------
SUB InvertLine( BYVAL xleft1 AS INTEGER ,BYVAL yFrom AS INTEGER, _
                BYVAL xleft2 AS INTEGER ,BYVAL yTo AS INTEGER )


    LOCAL hDC       AS LONG
    LOCAL nDrawMode AS LONG
    LOCAL oldpt     AS POINTAPI

    '*Get DC of ListBox
    hDC = GetDC(ghList)

    '*Use the default Pen color and style...

    '*Set the GDI foreground mix mode
    nDrawMode = SetROP2(hDC, %R2_NOT)

    '*Draw the Line
    CALL MoveToEx( hDC ,xLeft1 ,yFrom ,oldpt)
    CALL LineTo( hDC ,xLeft2 ,yTo)

    '*Restore DC
    CALL SetROP2(hDC, nDrawMode)
    CALL ReleaseDC(ghList, hDC)

END SUB

'--------------------------------------------------------------------------
' User Designed Custom Control Properties:
'
'--------------------------------------------------------------------------
SUB InitializePropertyItems()

    pItem(0).propName  =  "ToolTip Text"
    pItem(0).curValue  =  "Litte Red Riding Hood..."
    pItem(0).nItemType =  %PIT_EDIT
    pItem(0).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(0).propName))

    pItem(1).propName  =  "Enabled"
    pItem(1).curValue  =  "true"
    pItem(1).nItemType =  %PIT_COMBO
    pItem(1).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(1).propName))

    pItem(2).propName  =  "Visible"
    pItem(2).curValue  =  "true"
    pItem(2).nItemType =  %PIT_COMBO
    pItem(2).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(2).propName))

    pItem(3).propName  =  "Fore. Color"
    pItem(3).curValue  =  "RGB(255,255,0)"
    pItem(3).nItemType =  %PIT_COLOR
    pItem(3).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(3).propName))

    pItem(4).propName  =  "Back. Color"
    pItem(4).curValue  =  "RGB(255,0,128)"
    pItem(4).nItemType =  %PIT_COLOR
    pItem(4).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(4).propName))

    pItem(5).propName  =  "Opaque"
    pItem(5).curValue  =  "false"
    pItem(5).nItemType =  %PIT_COMBO
    pItem(5).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(5).propName))

    pItem(6).propName  =  "Auto. Scroll"
    pItem(6).curValue  =  "true"
    pItem(6).nItemType =  %PIT_COMBO
    pItem(6).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(6).propName))

    pItem(7).propName  =  "Double Buffered"
    pItem(7).curValue  =  "true"
    pItem(7).nItemType =  %PIT_COMBO
    pItem(7).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(7).propName))

    pItem(8).propName  =  "Font"
    pItem(8).curValue  =  "MS San Sarif"
    pItem(8).nItemType =  %PIT_FONT
    pItem(8).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(8).propName))

    pItem(9).propName  = "Text"
    pItem(9).curValue  =  "Big Bad Wolf!"
    pItem(9).nItemType =  %PIT_EDIT
    pItem(9).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(9).propName))

    pItem(10).propName  =  "Horiz. Align"
    pItem(10).curValue  =  "CENTER"
    pItem(10).nItemType =  %PIT_COMBO
    pItem(10).cmbItems  =  "CENTER|LEFT|RIGHT|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(10).propName))

    pItem(11).propName  =  "Vert. Align"
    pItem(11).curValue  =  "CENTER"
    pItem(11).nItemType =  %PIT_COMBO
    pItem(11).cmbItems  =  "CENTER|TOP|BOTTOM|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(11).propName))

    pItem(12).propName  =  "Bmp ,Icon"
    pItem(12).curValue  =  "none"
    pItem(12).nItemType =  %PIT_FILE
    pItem(12).cmbItems  =  ""
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(12).propName))

    pItem(13).propName  =  "Border Painted"
    pItem(13).curValue  =  "false"
    pItem(13).nItemType =  %PIT_COMBO
    pItem(13).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(13).propName))

    pItem(14).propName  =  "Fill Content Area"
    pItem(14).curValue  =  "true"
    pItem(14).nItemType =  %PIT_COMBO
    pItem(14).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(14).propName))

    pItem(15).propName  = "Focus Painted"
    pItem(15).curValue  =  "true"
    pItem(15).nItemType =  %PIT_COMBO
    pItem(15).cmbItems  =  "true|false|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(15).propName))

    pItem(16).propName  =  "Horiz. Text Pos."
    pItem(16).curValue  =  "RIGHT"
    pItem(16).nItemType =  %PIT_COMBO
    pItem(16).cmbItems  =  "RIGHT|LEFT|CENTER|LEADING|TRAILING|"
    CALL SendMessage(ghList,%LB_ADDSTRING,0,VARPTR(pItem(16).propName))

END SUB


'--------------------------------------------------------------------------
' Load 16 Custom colors up for our ChooseColor() Dialog
'--------------------------------------------------------------------------
SUB InitializeCustomColors()

  LOCAL lCounter AS LONG

  DIM cColor(0:15)

  'load your custom colors...
  RANDOMIZE TIMER
  FOR lCounter = 0 TO 15
    'example colors,
    cColor(lCounter) = RND(0,16777215)
  NEXT

END SUB


'--------------------------------------------------------------------------
' We don't have one yet, so just fill in with a place holder
'--------------------------------------------------------------------------
SUB InitializeUserCustomControl()

   ghUCC = CreateWindowEx(%WS_EX_CLIENTEDGE,"STATIC", _
                          "Explore Your Custom Designed Control       Here...", %WS_CHILD OR %WS_VISIBLE _
                          OR %WS_BORDER OR %WS_CLIPSIBLINGS OR %SS_NOTIFY _
                          OR %SS_CENTER, _
                          380, _
                          60, _
                          200, _
                          200, _
                          ghMain, _
                          %IDC_UCC, _
                          ghInst, _
                          BYVAL %NULL)


END SUB

    Comment

    Previous template Next
    Working...
    X
    😀
    🥰
    🤢
    😎
    😡
    👍
    👎

    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.

    I Agree