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

Properties List control

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

  • Properties List control

    This is a first attempt to make a properties list control self-contained so that it can be incorporated in an application with the miniumum of fuss. Having said, it is a single source file with a bit of a test harness included so that it can be run, marvelled at, and torn to shreds... It is not much tested and I have no doubt that versions will arise. If reposting the whole or major part, post here, else post comments in the Windows forum here


    Code:
    '--------------------------------------------------------------------------------------------
    ' Module:  PROPCON.Bas
    ' Desc:    Properties List control
    ' Interface:
    '          The control is driven by WM_USER messages, WM_USER is offset as follows:
    '          %our_add_property        = 100
    '          %our_get_property        = 102
    '          %our_get_property_count  = 103
    '          This being a properties list, the content is unlikely to be changed dynamically
    '          so I have saved 30 minutes by not coding a "del_property" or "set_property"
    '          method.
    '          Loading the property sheet with properties and their default values is
    '          shown in InitializePropertyItems.
    '          Extracting the properties and their values is done in the DEBUG button handler.
    '          The developer also has to handle the WM_MEASUREITEM message as shown.
    ' Issues:
    '          1. lack of thorough testing
    '          2. WM_MEASUREITEM
    ' Purpose: a standalone control for managing a properties list
    ' History: Listbox handling code borrowed from Jules Marchildon's post of 2001 , not changed much
    ' Date:    7-FEB-2008
    ' Name:    Chris Holbrook
    '
    '--------------------------------------------------------------------------------------------
    
    #COMPILE EXE
    #INCLUDE "WIN32API.INC"
    #INCLUDE "COMDLG32.INC"
    
    
    '---
    
    TYPE PROPERTYITEM
      propName  AS ASCIIZ*225
      curValue  AS ASCIIZ*255
      nItemType AS INTEGER
      cmbItems  AS ASCIIZ*255
      fptr      AS propertyitem PTR
    END TYPE
    
    ' message types - WM_USER offsets
    %our_add_property        = 100
    %our_get_property        = 101
    %our_get_property_count  = 102
    %our_MEASUREITEM         = 103
    %our_drawitem            = 104
    %our_lb_selchange        = 105
    %our_msg_max             = 106  ' must be highest WM_USER offset + 1
    
    '---
    %IDC_LISTBOX = 1000
    %IDC_COMBO   = 1001
    %IDC_BUTTON  = 1002
    %IDC_EDIT    = 1003
    %IDC_UCC     = 1004
    %IDC_DEBUG_BN = 1005
    
    'PIT = property item type, Button is default
    %PIT_COMBO   = 0
    %PIT_EDIT    = 1
    %PIT_COLOR   = 2
    %PIT_FONT    = 3
    %PIT_FILE    = 4
    '---
    DECLARE SUB InitializePropertyItems( hOwner AS DWORD, lCtlId AS LONG)
    
    DECLARE SUB InitializeCustomColors( pColors AS DWORD)
    DECLARE SUB OnSelChange(hlist AS DWORD, hcombo AS DWORD, hbutton AS DWORD, hedit AS DWORD, _
                    nDivider AS INTEGER)
    DECLARE SUB OnButtonClicked(hlist AS DWORD, pColors AS DWORD)
    DECLARE SUB InvertLine( BYVAL hList AS DWORD, 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
    
    '-------------------------------------------------------------
    ' common functions
    '------------------------------------------------------------------------------
    ' borrowed from Semen Matusovski
    FUNCTION CreateSuperClass(OldClassName AS STRING, NewClassName AS STRING, lpfnNewWndProc AS LONG, cbWndExtra AS LONG) AS LONG
    LOCAL wc AS WNDCLASSEX
    LOCAL result AS LONG
        wc.cbSize = SIZEOF(wc)
        IF GetClassInfoEx(BYVAL 0&, BYVAL STRPTR(OldClassName), wc) THEN
            CallWindowProc lpfnNewWndProc, 0, 0, wc.lpfnWndProc, wc.cbWndExtra
            wc.hInstance = GetModuleHandle(BYVAL 0&)
            wc.lpszClassName = STRPTR(NewClassName)
            wc.lpfnWndProc = lpfnNewWndProc
            wc.cbWndExtra = wc.cbWndExtra + cbWndExtra
            result = RegisterClassEx(wc)
            FUNCTION = result
        END IF
    END FUNCTION
    
    '-------------------------------------------------------------
    ' 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( LBWndProc )
        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
        IF ISFALSE(CreateSuperClass("LISTBOX","OurLB", CODEPTR(ListBoxProc), 4)) THEN EXIT FUNCTION
    
        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 LBWndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                         BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
    
        STATIC hlist, hfont, hinstance, hwndBn         AS DWORD
        LOCAL lpMs            AS MEASUREITEMSTRUCT PTR
        LOCAL psz AS ASCIZ PTR
        LOCAL result, nrows, i AS LONG
        LOCAL sz AS ASCIZ * 255
        LOCAL pitem          AS PROPERTYITEM PTR
        LOCAL s AS STRING
    
    '---
    
        SELECT CASE wMsg
            CASE %WM_CREATE
                hinstance = getmodulehandle(BYVAL 0)
                '  Create the OwnerDraw List box for our control properties...
                hList  = CreateWindowEx(%WS_EX_CLIENTEDGE, "OurLB", "", _
                         %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, _
                         hWnd, %IDC_LISTBOX, hInstance, BYVAL %NULL)
    
                hFont = MakeFont("Courier New", 9)
                CALL SendMessage( hList, %WM_SETFONT, hFont, 0 )
                CALL InitializePropertyItems(hWnd, %IDC_LISTBOX)
    
                ' Create a label control
                hWndBN = CreateWindowEx(%NULL, "Static","DEBUG", _
                         %SS_LEFT OR %WS_VISIBLE OR %WS_CHILD OR %SS_NOTIFY, _
                         335, 280, 50, 15, _
                         hWnd, %IDC_DEBUG_BN, hInstance, BYVAL %NULL)
    
    
                FUNCTION = %TRUE
                EXIT FUNCTION
    
            CASE %WM_MEASUREITEM
                lpMs = LPARAM
                'arbitrary number for height
                @lpMs.itemHeight = 20
    
                FUNCTION = %TRUE
                EXIT FUNCTION
    
            CASE %WM_DRAWITEM
                sendmessage (hlist, %WM_USER + %our_DRAWITEM, wparam, lparam) ' pass the message on to the superclassed LB control
    
            CASE %WM_COMMAND
                'ListBox control notifications...
                SELECT CASE LOWRD(wParam)
                       CASE %IDC_LISTBOX
                            SELECT CASE HIWRD(wParam)
                                   CASE %LBN_SELCHANGE
                                       ' nudge the listbox control
                                       sendmessage(hlist, %WM_USER + %our_lb_selchange, 0, 0)
                            END SELECT
                       CASE %IDC_DEBUG_BN
                            result = sendmessage(hlist, %WM_USER + %our_get_property_count,0,0)
                            ? "there are" + STR$(result) + " properties in the list"
                            ' work through listbox getting each property in turn,
                            ' requesting its values & formatting them for display
                            nrows = sendmessage(hlist, %LB_GETCOUNT,0,0)
                            FOR i = 1 TO nrows
                                CALL sendmessage(hlist, %LB_GETTEXT, i, VARPTR(sz))
                                pitem = sendmessage ( hlist, %WM_USER + %our_get_property, VARPTR(sz), 0)
                                s = s + "name = " + TRIM$(@pitem.Propname) + "," + _
                                        "CurValue = " + TRIM$(@pitem.CurValue) + ","
                                SELECT CASE @pitem.nitemtype
                                    CASE %PIT_COMBO
                                        s = s + "nItemType = COMBO"
                                    CASE %PIT_EDIT
                                        s = s + "nItemType = EDIT"
                                    CASE %PIT_COLOR
                                        s = s + "nItemType = COLOR"
                                    CASE %PIT_FONT
                                        s = s + "nItemType = FONT"
                                    CASE %PIT_FILE
                                        s = s + "nItemType = FILE"
                                END SELECT
                                s = s + ",cmbitems = " + TRIM$(@pitem.CmbItems) + "," + _
                                        "fptr = " + STR$( @pitem.fptr) + $CRLF
                            NEXT
                            ? s
                END SELECT
            CASE %WM_DESTROY
                deleteObject hfont
        END SELECT
        FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
    END FUNCTION
    
    
    ' LBN_SELCHANGE:
    '----------------------------------------------------------------------------
    SUB OnSelChange(hlist AS DWORD, hcombo AS DWORD, hbutton AS DWORD, hedit AS DWORD, _
                    nDivider AS INTEGER)
    
        LOCAL lBoxSelText AS STRING
        LOCAL rc AS RECT
        LOCAL cursel AS LONG
        LOCAL nlastbox AS LONG
        LOCAL pitem AS PROPERTYITEM PTR
        LOCAL sz AS ASCIZ * 255
    
        curSel = SendMessage( hList, %LB_GETCURSEL, 0, 0 )
        sendmessage ( hlist, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
        lBoxSelText = sz
        pitem = sendmessage ( hList, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
        CALL SendMessage( hList, %LB_GETITEMRECT, curSel, VARPTR(rc) )
    
        rc.nleft = nDivider
    
        IF hCombo  <> 0 THEN CALL ShowWindow( hCombo,  %SW_HIDE )
        IF hButton <> 0 THEN CALL ShowWindow( hButton, %SW_HIDE )
        IF hEdit   <> 0 THEN CALL ShowWindow( hEdit,   %SW_HIDE )
    
        IF @pItem.nItemType = %PIT_COMBO  THEN
    
            'display the combo box and move it to the new location
            nLastBox = 0
    
            IF hCombo <> 0 THEN
               CALL MoveWindow( hCombo,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.cmbItems
            lBoxSelText = @pItem.curValue
    
            CALL SendMessage( hCombo,%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(hCombo, %CB_ADDSTRING, i&-1, STRPTR(dataItem$) )
            NEXT
    
            CALL ShowWindow( hCombo,%SW_SHOW )
            CALL SetFocus( hCombo )
            'Call SetFocus( ghList )
    
            'jump to the property's current value in the combo box
            j& = SendMessage(hCombo,%CB_FINDSTRINGEXACT,0,STRPTR(lBoxSelText) )
            IF  j& <> %CB_ERR  THEN
                CALL SendMessage( hCombo,%CB_SETCURSEL,j&,0 )
            ELSE
                'there is no current value, so default to first in list
                CALL SendMessage( hCombo,%CB_SETCURSEL,0,0 )
            END IF
    
        ELSEIF @pItem.nItemType = %PIT_EDIT  THEN
    
            'display edit box
            nLastBox   = 1
            rc.nbottom = rc.nbottom - 3
    
            IF hEdit <> 0 THEN
               CALL MoveWindow( hEdit,rc.nleft+1,rc.ntop+3,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
            END IF
    
            lBoxSelText = @pItem.curValue
    
            CALL ShowWindow( hEdit, %SW_SHOW )
            CALL SetFocus( hEdit )
            'Call SetFocus( ghList )
    
            'set the text in the edit box to the property's current value
            CALL SendMessage(hEdit, %WM_SETTEXT, 0, STRPTR(lBoxSelText) )
    
        ELSE
            'displays a button if the property is a Color/File/Font chooser
            nLastBox = 2
    
            nWidth& = rc.nright - rc.nleft
    
            IF  nWidth& > 25  THEN
                rc.nleft   = rc.nright  - 25
            END IF
    
            rc.nbottom = rc.nbottom - 3
    
            IF hButton <> 0  THEN
               CALL MoveWindow( hButton,rc.nleft,rc.ntop,rc.nRight -rc.nleft, rc.nBottom -rc.ntop, 1 )
            END IF
    
            CALL ShowWindow( hButton, %SW_SHOW )
            CALL SetFocus( hButton )
            'Call SetFocus( ghList )
            '---
    
        END IF
    
    END SUB
    '----------------------------------------------------------------------------
    ' BN_CLICKED:
    '----------------------------------------------------------------------------
    SUB OnButtonClicked(hlist AS DWORD, pColors AS DWORD)
    
         LOCAL lBoxSelText    AS STRING
         LOCAL initClr        AS DWORD
         LOCAL currClr        AS ASCIIZ*255
         LOCAL clrStr         AS ASCIIZ*255
         LOCAL ColorSpec      AS CHOOSECOLORAPI
         LOCAL lResult, cursel        AS LONG
         LOCAL lCounter       AS LONG
         LOCAL lCustomColor() AS LONG
         LOCAL pitem AS PROPERTYITEM PTR
         LOCAL sz AS ASCIZ * 255
    
        'display the appropriate common dialog depending on what type
        'of chooser is associated with the property
        ' get current listbox selection
        cursel = sendmessage ( hlist, %LB_GETCURSEL,0,0)
        sendmessage ( hlist, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
        lBoxSelText = TRIM$(sz)
        pitem = sendmessage ( hList, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
        'First check for the Choose Color dialog...
        SELECT CASE @pItem.nItemType
            CASE %PIT_COLOR
    
                currClr = @pItem.curValue
    
                IF  currClr > "" THEN
    
                    'parse the property's current color value
                    currClr = LTRIM$(currClr,"RGB(")
                    currClr = RTRIM$(currClr,")")
    
                    initClr = RGB(VAL(PARSE$(currClr,d$,1)), _
                                 VAL(PARSE$(currClr,d$,2)),  _
                                 VAL(PARSE$(currClr,d$,3)))
                ELSE
                    'use a default instead
                    initClr = RGB( 255,128,128 )
                END IF
    
                ColorSpec.lStructSize  = LEN(ColorSpec)
                ColorSpec.hwndOwner    = hList
                ColorSpec.lpCustColors = pColors
                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)
    
                    'Note order of RGB, COLORREF 0x00bbggrr
                    clrStr = "RGB(" + TRIM$(STR$(VAL("&H" + RIGHT$(ClrStr,2)))) + _
                                "," + TRIM$(STR$(VAL("&H" + MID$  (ClrStr,3,2)))) + _
                                "," + TRIM$(STR$(VAL("&H" + LEFT$ (ClrStr,2)))) + ")"
                    @pItem.curValue = clrStr
    
                    'Call ShowWindow( ghButton,%SW_HIDE )
    
                    CALL InvalidateRect( hList,BYVAL %NULL,1)
                    CALL UpdateWindow ( hList )
                 END IF
    
            CASE %PIT_FILE
                'Next check for the Open File Dialog...
    
                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.curValue
                IF currPath$ = "none" THEN
                   fName$ = ""
                ELSE
                   fName$ = currPath$
                END IF
    
                'use simple Open dialog for demo...
                tmp& = OpenFileDialog(getparent(hlist),"Select File:",fName$,CURDIR$,zTxt,"BMP", _
                                      %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES)
                IF tmp& THEN
                    @pItem.curValue = fName$
                    CALL InvalidateRect(hList,BYVAL %NULL,1)
                    CALL UpdateWindow ( hList )
                END IF
    
        '    END IF '<remove later>
    
            'Last, check for the ChooseFont() dialog...
            CASE %PIT_FONT
    
                DIM cf AS CHOOSEFONTAPI
                DIM lfFont AS LOGFONT
                cf.lStructSize = SIZEOF(cf)
                cf.hWndOwner   = getparent(hlist)
                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
                    'ToDo: Not included in orgional C++, get the Font height...
                    @pItem.curValue = faceName$
    
                    CALL InvalidateRect( hList,BYVAL %NULL,1)
                    CALL UpdateWindow ( hList )
    
                END IF
    
        END SELECT
    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
    
    
    '-------------------------------------------------------------------------
    '' SuperClassed ListBox Control Procedure:
    '-------------------------------------------------------------------------
    CALLBACK FUNCTION ListBoxProc
    
        LOCAL lBoxSelText AS STRING
        STATIC OldProc AS LONG, OffsetWndExtra AS LONG
        LOCAL sz AS ASCIZ * 64
        LOCAL psz AS ASCIZ PTR
        LOCAL cursel, hDC, nindex AS LONG
        LOCAL r, rc, rc2, rectfull AS rect
        LOCAL pt AS POINTAPI
        STATIC hbrush, hCursorSize, hcursorarrow, hcombo, hedit, hbutton, hfont, hinst AS DWORD
        LOCAL p_item, q_item, r_item AS PROPERTYITEM PTR
        LOCAL h, i            AS LONG
        STATIC pitem, ppty    AS propertyitem PTR
    
        STATIC nDivider       AS INTEGER
        STATIC nDivTop        AS INTEGER
        STATIC nDivBtm        AS INTEGER
        STATIC nOldDivX       AS INTEGER
        STATIC nLastBox       AS INTEGER
        STATIC bTracking      AS LONG
        STATIC bDivIsSet      AS INTEGER
        DIM Ccolor(0 TO 15)   AS STATIC LONG
        LOCAL lpDs            AS DRAWITEMSTRUCT PTR
        LOCAL pdw             AS DWORD PTR
        LOCAL lcreating AS LONG
    
        '
        ' message from  CreateSuperClass to give us the WNDPROC for the base class
        IF CBHNDL = 0 THEN
            OldProc = CBWPARAM
            OffsetWndExtra = CBLPARAM
            EXIT FUNCTION
        END IF
        '
        SELECT CASE CBMSG
    
            CASE %WM_CREATE
                lcreating = %true
                hCursorArrow =  LoadCursor( %NULL, BYVAL %IDC_ARROW )
                hinst = getmodulehandle(BYVAL 0)
                hCursorSize  =  LoadCursor( %NULL, BYVAL %IDC_SIZEWE )
                bTracking = %FALSE
                nDivider  = 0
                bDivIsSet = %FALSE
                '  Create the controls that will need to edit the Properties with.
                '  They are all hidden for now and resized later.
                hButton = CreateWindowEx(0,"BUTTON","...", _
                                          %WS_CHILD OR %WS_CLIPSIBLINGS OR %BS_PUSHBUTTON, _
                                          0,0,8,12, _
                                          CBHNDL, %IDC_BUTTON, hInst, BYVAL %NULL)
    
                hCombo  = CreateWindowEx(0,"COMBOBOX", "", _
                                          %WS_CHILD OR %CBS_DROPDOWNLIST OR %CBS_NOINTEGRALHEIGHT, _
                                          0,0,10,100, _
                                          CBHNDL, %IDC_COMBO, hInst, BYVAL %NULL)
    
                hEdit   = CreateWindowEx(0,"EDIT", "True", _
                                          %WS_CHILD OR %WS_CLIPSIBLINGS OR %ES_LEFT OR %ES_AUTOHSCROLL OR %WS_BORDER, _
                                          0,0,10,20, _
                                          CBHNDL, %IDC_EDIT, hInst, BYVAL %NULL)
                CALL InitializeCustomColors( VARPTR(Ccolor(0)))
                lcreating = %false
            CASE %WM_SETFONT
                hfont = CBWPARAM
                CALL SendMessage( hEdit, %WM_SETFONT, hFont, 0 )
                CALL SendMessage( hCombo, %WM_SETFONT, hFont, 0 )
                ' NB SetFont does not return a value
    
            'Catch the Combo,Edit,Button child control notifications here...
    
            CASE %WM_COMMAND
                cursel = sendmessage ( CBHNDL, %LB_GETCURSEL,0,0)
                sendmessage ( CBHNDL, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
                lBoxSelText = TRIM$(sz)
                pitem = sendmessage ( CBHNDL, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
    
                SELECT CASE CBCTL
                       CASE %IDC_COMBO
                            IF (CBCTLMSG = %CBN_SELCHANGE) THEN
                                LOCAL selStr AS ASCIIZ*255
                                IF hCombo <> 0  THEN
                                   idx& = SendMessage( hCombo, %CB_GETCURSEL ,0 ,0 )
                                   CALL SendMessage( hCombo, %CB_GETLBTEXT, idx& , VARPTR(selStr) )
                                   @pItem.curValue = selStr
                                END IF
                            END IF
    
                       CASE %IDC_EDIT
                            IF (CBCTLMSG = %EN_CHANGE) THEN
                                LOCAL newStr AS ASCIIZ*255
                                tLen&  = SendMessage(hEdit, %WM_GETTEXTLENGTH, 0, 0) + 1
                                newStr = SPACE$(tLen&)
                                CALL SendMessage(hEdit, %WM_GETTEXT, tLen&, VARPTR(newStr))
                                IF pitem <> 0 THEN ' no items exist during initialisation!
                                    @pItem.curValue = newStr
                                END IF
                            END IF
    
                       CASE %IDC_BUTTON
                            IF (CBCTLMSG = %BN_CLICKED) THEN
                                cursel = sendmessage ( CBHNDL, %LB_GETCURSEL,0,0)
                                CALL OnButtonClicked( CBHNDL, VARPTR(Ccolor(0)))
                            END IF
    
                END SELECT
    
            CASE %WM_LBUTTONDOWN
                IF hCombo  <> 0 THEN CALL ShowWindow( hCombo,  %SW_HIDE )
                IF hEdit   <> 0 THEN CALL ShowWindow( hEdit,   %SW_HIDE )
                IF hButton <> 0 THEN CALL ShowWindow( hButton, %SW_HIDE )
    
                '-----------------------[ Splitter ]-----------------------
                pt.x = LOWRD(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                IF ((pt.x >= nDivider-5) AND (pt.x <= nDivider+5)) THEN
                    'if mouse clicked on divider line, then start resizing
                    CALL SetCursor(hCursorSize)
    
                    CALL GetWindowRect( CBHNDL ,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( CBHNDL ,rc )
                    bTracking = %TRUE
    
                    nDivTop   = rc.ntop
                    nDivBtm   = rc.nbottom
                    nOldDivX  = pt.x
    
                    CALL InvertLine( CBHNDL, nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
    
                    'capture the mouse
                    CALL SetCapture(CBHNDL)
    
                END IF
    
    
            CASE %WM_MOUSEMOVE
                pt.x = LOWRD(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                'move divider line to the mouse position
                'if columns are currently being resized
                IF bTracking = %TRUE  THEN
    
                    'remove old divider line
                    CALL InvertLine( CBHNDL, nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
    
                    'draw new divider line
                    CALL InvertLine( CBHNDL, 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(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                '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( CBHNDL, pt.x ,nDivTop ,pt.x ,nDivBtm )
    
    
                    'set the divider position to the new value
                    nDivider = pt.x
    
                    'Self paint the ListBox control...
                    CALL InvalidateRect(CBHNDL ,BYVAL %NULL, 1)
                    CALL UpdateWindow(CBHNDL)
    
                END IF
    
               CASE %WM_CAPTURECHANGED
                    IF CBLPARAM <> getparent(CBHNDL) THEN
                        IF bTracking = %TRUE THEN
                            bTracking = %FALSE
                            CALL ReleaseCapture()
                            CALL ClipCursor( BYVAL %NULL )
                            CALL InvalidateRect(CBHNDL ,BYVAL %NULL, 1)
                            CALL UpdateWindow(CBHNDL)
                        END IF
                    END IF
               '---------------------[ end of splitter ]------------------
                '---
    
            ' user messages
            CASE %WM_USER + %our_lb_selchange ' sent when LB_SELCHANGE rec'd by parent
                curSel = SendMessage( CBHNDL, %LB_GETCURSEL, 0, 0 )
                CALL OnSelChange(CBHNDL, hcombo, hbutton, hedit, ndivider)
    
            CASE %WM_USER + %our_DRAWITEM ' parent has rec'd a WM_DRAWITEM msg
                lpDs = CBLPARAM
                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
                sendmessage ( CBHNDL, %LB_GETTEXT, nIndex, VARPTR(sz)) ' get selected text = propertyname
                lBoxSelText = TRIM$(sz)
                pitem = sendmessage ( CBHNDL, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
                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.propName, _
                                   LEN(@pItem.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.curValue, _
                                  LEN(@pItem.curValue), _
                                  rc, %DT_LEFT OR %DT_SINGLELINE )
                END IF
    
                '<insert here>  Add some kind of item focus rect
    
                FUNCTION = %TRUE
                EXIT FUNCTION
    
            CASE %WM_USER + %our_add_property
                BEEP
                pdw = CBLPARAM
                p_item = CBLPARAM
                ' grab memory to hold new property and ititialise to zeros
                h = GlobalAlloc ( %GPTR, SIZEOF(PropertyItem))
                ' move property details into memory
                movememory ( BYVAL h, BYVAL pdw, SIZEOF(PROPERTYITEM))
                ' add it into list at end
                IF ppty = %NULL THEN ' empty list
                    ppty = h
                ELSE
                    p_item = ppty
                    WHILE @p_item.fptr <> %NULL
                        p_item = @p_item.fptr
                    WEND
                    @p_item.fptr = h
                END IF
                q_item = h
                sz = @q_item.propname
                pitem = q_item          ' pitem is static!
                CALL SendMessage(CBHNDL,%LB_ADDSTRING,0,VARPTR(sz))
                EXIT FUNCTION
    
            CASE %WM_USER + %our_get_property ' wparam has a ptr to propertyname
                ' find property by name
                p_item = ppty
                IF p_item = %NULL THEN EXIT FUNCTION ' empty list
                psz = CBWPARAM
                WHILE TRIM$(@p_item.propname)  <> TRIM$(@psz)
                    p_item = @p_item.fptr
                    IF p_item = %NULL THEN EXIT FUNCTION ' return null pointer
                WEND
                ' return msg with pointer to it
                FUNCTION = p_item ' return pointer to property
                EXIT FUNCTION
                'sendmessage ( hParent, %WM_USER + %our_ispty, 0, p_item)
    
    
            CASE %WM_USER + %our_get_property_count
                ' count properties in list
                p_item = ppty
                IF p_item = %NULL THEN EXIT FUNCTION ' return zero
                WHILE %TRUE
                    INCR i
                    p_item = @p_item.fptr
                    IF p_item = %NULL THEN
                        FUNCTION = i
                        EXIT FUNCTION
                    END IF
                WEND
            '
            CASE %WM_DESTROY
                ' deallocate memory in property linked list
                p_item = ppty
                WHILE p_item <> %null
                    q_item = p_item
                    p_item = @p_item.fptr
                    globalfree( BYVAL q_item )
                WEND
                ppty = %NULL
                '
                CALL PostQuitMessage( 0 )
        END SELECT
    
        ' if the message was received as a user message, it is not processed further
        IF (CBMSG > %WM_USER) AND ( CBMSG < %WM_USER + %our_msg_max) THEN EXIT FUNCTION
        '
        FUNCTION = CallWindowProc(OldProc, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    
    
    '--------------------------------------------------------------------------
    ' InvertLine()
    '--------------------------------------------------------------------------
    SUB InvertLine( BYVAL hList AS DWORD, 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(hList)
    
        '*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(hList, hDC)
    
    END SUB
    
    '--------------------------------------------------------------------------
    ' User Designed Custom Control Properties:
    '
    '--------------------------------------------------------------------------
    ' This sub is outside the custom control so it needs to know where the CC is
    ' for which purpose the parent hWnd and control id are passed in
    SUB InitializePropertyItems( hOwner AS DWORD, lCtlId AS LONG)
        LOCAL pi AS propertyitem
    
    
        pi.propName  =  "ToolTip Text"
        pi.curValue  =  "Litte Red Riding Hood..."
        pi.nItemType =  %PIT_EDIT
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Enabled"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Visible"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Fore. Color"
        pi.curValue  =  "RGB(255,255,0)"
        pi.nItemType =  %PIT_COLOR
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Back. Color"
        pi.curValue  =  "RGB(255,0,128)"
        pi.nItemType =  %PIT_COLOR
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Opaque"
        pi.curValue  =  "false"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Auto. Scroll"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Double Buffered"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Font"
        pi.curValue  =  "MS San Sarif"
        pi.nItemType =  %PIT_FONT
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  = "Text"
        pi.curValue  =  "Big Bad Wolf!"
        pi.nItemType =  %PIT_EDIT
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Horiz. Align"
        pi.curValue  =  "CENTER"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "CENTER|LEFT|RIGHT|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Vert. Align"
        pi.curValue  =  "CENTER"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "CENTER|TOP|BOTTOM|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Bmp ,Icon"
        pi.curValue  =  "none"
        pi.nItemType =  %PIT_FILE
        pi.cmbItems  =  ""
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Border Painted"
        pi.curValue  =  "false"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Fill Content Area"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  = "Focus Painted"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
        pi.propName  =  "Horiz. Text Pos."
        pi.curValue  =  "RIGHT"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "RIGHT|LEFT|CENTER|LEADING|TRAILING|"
        CALL SendMessage(getdlgitem(howner, lCtlId),%WM_USER + %our_add_property, 0,VARPTR(pi))
    
    END SUB
    
    
    '--------------------------------------------------------------------------
    ' Load 16 Custom colors up for our ChooseColor() Dialog
    '--------------------------------------------------------------------------
    SUB InitializeCustomColors( pColors AS DWORD)
    
      LOCAL lCounter AS LONG
      LOCAL pl       AS LONG PTR
      'load your custom colors...
      RANDOMIZE TIMER
      pl = pColors
      FOR lCounter = 0 TO 15
        'example colors,
        @pl = RND(0,16777215)
        INCR pl
      NEXT
    
    END SUB
    Last edited by Chris Holbrook; 7 Feb 2008, 06:20 AM.

  • #2
    Example of use from a DDT application etc

    More changes, see comments in the INCLUDE file header for information.

    The INCLUDE file can of course also be used in an SDK application.
    Code:
    '--------------------------------------------------------------------------------------------
    ' Module:  PROPCON.INC
    ' Desc:    Properties List control. Maintains a properties list comprising text, numeric,
    '            Color, File, Font, and text selection (via combo box) property types. Uses
    '            common dialogs for Color, File, and Font pickers.
    ' Interface:
    '          The control is driven by WM_USER messages to add, get, set, and count properties.
    '          A list of PROPERTYITEM structures is used to contain properties, and is built
    '          by the control.
    '          Loading the property sheet with properties and their default values is
    '          easily done by declaring a PROPERTYITEM structure, populating it and sending a message
    '          to the control to add it to the list.
    '          Extracting the properties is also done by messaging.
    '          The linked list of PROPERYITEM structures is lost when the control is closed
    '          The developer also has to handle the WM_DRAWITEM message and WM_COMMAND LBN_SELCHANGE
    '          notification to pass in equivalent user messages to the control.
    '          If a font is sent to the control, it is cascaded to the sub-controls.
    ' Purpose: a standalone control for managing a properties list
    ' Acknowledgement: Thanks to Jules Marchildon for the listbox handling code from which this
    '          control grew.
    ' Date:    8-FEB-2008 pm
    ' Version: 1.02
    ' Name:    Chris Holbrook
    '
    '--------------------------------------------------------------------------------------------
    TYPE PROPERTYITEM
      propName  AS ASCIZ   * 32
      sOwner    AS ASCIZ   * 32      ' name of property who owns the item
      curValue  AS ASCIIZ  *255
      nItemType AS INTEGER
      subtype   AS LONG
      cmbItems  AS ASCIIZ  *255
      fptr      AS propertyitem PTR
    '  tlf       as logfont
    END TYPE
    
    
    ' subtypes
    %PITS_NULL               = 0
    %PITS_FontAtts           = 1
    %PITS_FontSize           = 2
    %PITS_FontColor          = 3
    %PITS_COLOR              = 4
    
    
    ' message types - WM_USER offsets
    %our_add_property        = 100
    %our_get_property        = 101
    %our_set_property        = 102
    %our_get_property_count  = 103
    %our_MEASUREITEM         = 104
    %our_drawitem            = 105
    %our_lb_selchange        = 106
    %our_msg_max             = 107  ' must be highest WM_USER offset + 1
    
    '---
    %IDC_LISTBOX = 1000
    %IDC_COMBO   = 1001
    %IDC_BUTTON  = 1002
    %IDC_EDIT    = 1003
    %IDC_EDNUM   = 1004
    
    'PIT = property item type, Button is default
    %PIT_COMBO   = 0
    %PIT_EDIT    = 1
    %PIT_COLOR   = 2
    %PIT_FONT    = 3
    %PIT_FILE    = 4
    %PIT_EDNUM   = 5
    %PIT_RO      = 6
    '---
    DECLARE SUB InitializeCustomColors( pColors AS DWORD)
    DECLARE SUB OnSelChange(hlist AS DWORD, hcombo AS DWORD, hbutton AS DWORD, hedit AS DWORD, _
                    hednum AS DWORD, nDivider AS INTEGER)
    DECLARE SUB OnButtonClicked(hlist AS DWORD, pColors AS DWORD)
    DECLARE SUB InvertLine( BYVAL hList AS DWORD, 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
    
    '-------------------------------------------------------------
    ' common functions
    '------------------------------------------------------------------------------
    '--------------------------------------------------------------------------
    ' Load 16 Custom colors up for our ChooseColor() Dialog
    '--------------------------------------------------------------------------
    SUB InitializeCustomColors( pColors AS DWORD)
    
      LOCAL lCounter AS LONG
      LOCAL pl       AS LONG PTR
      'load your custom colors...
      RANDOMIZE TIMER
      pl = pColors
      FOR lCounter = 0 TO 15
        'example colors,
        @pl = RND(0,16777215)
        INCR pl
      NEXT
    
    END SUB
    '--------------------------------------------------------------------------
    ' borrowed from Semen Matusovski
    FUNCTION CreateSuperClass(OldClassName AS STRING, NewClassName AS STRING, lpfnNewWndProc AS LONG, cbWndExtra AS LONG) AS LONG
    LOCAL wc AS WNDCLASSEX
    LOCAL result AS LONG
        wc.cbSize = SIZEOF(wc)
        IF GetClassInfoEx(BYVAL 0&, BYVAL STRPTR(OldClassName), wc) THEN
            CallWindowProc lpfnNewWndProc, 0, 0, wc.lpfnWndProc, wc.cbWndExtra
            wc.hInstance = GetModuleHandle(BYVAL 0&)
            wc.lpszClassName = STRPTR(NewClassName)
            wc.lpfnWndProc = lpfnNewWndProc
            wc.cbWndExtra = wc.cbWndExtra + cbWndExtra
            result = RegisterClassEx(wc)
            FUNCTION = result
        END IF
    END FUNCTION
    '----------------------------------------------------------------------------
    SUB OnSelChange(hlist AS DWORD, hcombo AS DWORD, hbutton AS DWORD, hedit AS DWORD, _
                    hednum AS DWORD, nDivider AS INTEGER)
    
        LOCAL cmbitems, lBoxSelText, s AS STRING
        LOCAL rc AS RECT
        LOCAL cursel AS LONG
        LOCAL nlastbox AS LONG
        LOCAL pitem AS PROPERTYITEM PTR
        LOCAL sz AS ASCIZ * 255
        LOCAL i, j, ncount AS LONG
    
    
        curSel = SendMessage( hList, %LB_GETCURSEL, 0, 0 )
        sendmessage ( hlist, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
        lBoxSelText = sz
        pitem = sendmessage ( hList, %WM_USER + %our_get_property, VARPTR(sz), 0) ' get pointer to item structure
        CALL SendMessage( hList, %LB_GETITEMRECT, curSel, VARPTR(rc) )
    
        rc.nleft = nDivider
    
        IF hCombo  <> 0 THEN CALL ShowWindow( hCombo,  %SW_HIDE )
        IF hButton <> 0 THEN CALL ShowWindow( hButton, %SW_HIDE )
        IF hEdit   <> 0 THEN CALL ShowWindow( hEdit,   %SW_HIDE )
    
        SELECT CASE @pItem.nItemType
            CASE %PIT_COMBO
                'display the combo box and move it to the new location
                nLastBox = 0
    
                IF hCombo <> 0 THEN
                   CALL MoveWindow( hCombo,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    = TRIM$(@pItem.cmbItems)
                lBoxSelText = @pItem.curValue
    
                CALL SendMessage( hCombo,%CB_RESETCONTENT, 0,0 )
    
                nCount = TALLY(cmbItems,"|")
    
                FOR i& = 1 TO nCount&
                    s = PARSE$(cmbItems,"|",i)
                    'add each string to the ComboBox
                    CALL SendMessage(hCombo, %CB_ADDSTRING, i-1, STRPTR(s) )
                NEXT
    
                CALL ShowWindow( hCombo,%SW_SHOW )
                CALL SetFocus( hCombo )
                'Call SetFocus( ghList )
    
                'jump to the property's current value in the combo box
                j = SendMessage(hCombo,%CB_FINDSTRINGEXACT,0,STRPTR(lBoxSelText) )
                IF  j <> %CB_ERR  THEN
                    CALL SendMessage( hCombo,%CB_SETCURSEL, j, 0 )
                ELSE
                    'there is no current value, so default to first in list
                    CALL SendMessage( hCombo,%CB_SETCURSEL,0,0 )
                END IF
    
            CASE %PIT_EDIT
                'display edit box
                nLastBox   = 1
                rc.nbottom = rc.nbottom - 3
    
                IF hEdit <> 0 THEN
                   CALL MoveWindow( hEdit,rc.nleft+1,rc.ntop+1,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
                END IF
    
                lBoxSelText = @pItem.curValue
    
                CALL ShowWindow( hEdit, %SW_SHOW )
                CALL SetFocus( hEdit )
                'Call SetFocus( ghList )
    
                'set the text in the edit box to the property's current value
                CALL SendMessage(hEdit, %WM_SETTEXT, 0, STRPTR(lBoxSelText) )
    
            CASE %PIT_EDNUM
                'display edit box
                nLastBox   = 1
                rc.nbottom = rc.nbottom - 3
    
                IF hEdNum <> 0 THEN
                   CALL MoveWindow( hEdNum,rc.nleft+1,rc.ntop+1,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
                END IF
    
                lBoxSelText = @pItem.curValue
    
                CALL ShowWindow( hEdNum, %SW_SHOW )
                CALL SetFocus( hEdNum )
                'set the text in the edit box to the property's current value
                CALL SendMessage(hEdNum, %WM_SETTEXT, 0, STRPTR(lBoxSelText) )
            CASE %PIT_RO
                ' readonly - no action
            CASE ELSE
                'displays a button if the property is a Color/File/Font chooser
                nLastBox = 2
    
                'nWidth& = rc.nright - rc.nleft
    
                IF  (rc.nright - rc.nleft) > 25  THEN
                    rc.nleft   = rc.nright  - 25
                END IF
    
                rc.nbottom = rc.nbottom - 3
    
                IF hButton <> 0  THEN
                   CALL MoveWindow( hButton,rc.nleft,rc.ntop,rc.nRight -rc.nleft, rc.nBottom -rc.ntop, 1 )
                END IF
    
                CALL ShowWindow( hButton, %SW_SHOW )
                CALL SetFocus( hButton )
                'Call SetFocus( ghList )
                '---
        END SELECT
    
    END SUB
    '----------------------------------------------------------------------------
    ' BN_CLICKED:
    '----------------------------------------------------------------------------
    ' convert a string with decimal values like "RGB(123,4,255" to a color value
    FUNCTION Str2RGB ( s AS STRING) AS LONG
        FUNCTION = RGB ( VAL(PARSE$(s,ANY "(,)",2)), _
                         VAL(PARSE$(s,ANY "(,)",3)), _
                         VAL(PARSE$(s,ANY "(,)",4)) )
    END FUNCTION
    '----------------------------------------------------------------------------
    FUNCTION RGB2Str ( lcolor AS LONG ) AS STRING
        LOCAL s AS STRING
    
        s = HEX$(lcolor,6)
        'Note order of RGB, COLORREF 0x00bbggrr
        s = "RGB(" + TRIM$(STR$(VAL("&H" + RIGHT$(s,2)))) + _
                    "," + TRIM$(STR$(VAL("&H" + MID$  (s,3,2)))) + _
                    "," + TRIM$(STR$(VAL("&H" + LEFT$ (s,2)))) + ")"
        FUNCTION = s
    END FUNCTION
    '----------------------------------------------------------------------------
    FUNCTION FindSubProperty ( hWnd AS DWORD, sOwner AS STRING, subType AS LONG) AS DWORD
        LOCAL sz AS ASCIZ * 255
        LOCAL i, n AS LONG
        LOCAL pitem AS PROPERTYITEM PTR
    
        ' get count of properties
        n = sendmessage( hWnd, %WM_USER + %our_get_property_count, 0, 0)
        ' find a property with the requisite Owner & subtype
        FOR i = 1 TO n
            sendmessage ( hWnd, %LB_GETTEXT, i, VARPTR(sz))
            pitem = sendmessage ( hWnd, %WM_USER + %our_get_property, VARPTR(sz), 0 )
            IF TRIM$(@pitem.sowner) <> TRIM$(sOwner) THEN ITERATE
            IF @pitem.Subtype <> subtype THEN ITERATE
            FUNCTION = pitem
            EXIT FUNCTION
        NEXT
    END FUNCTION
    '----------------------------------------------------------------------------
    SUB OnButtonClicked(hlist AS DWORD, pColors AS DWORD)
    
         LOCAL lBoxSelText, s, sowner    AS STRING
         LOCAL initClr        AS DWORD
         LOCAL currClr        AS ASCIIZ*255
         LOCAL clrStr         AS ASCIIZ*255
         LOCAL ColorSpec      AS CHOOSECOLORAPI
         LOCAL lResult, cursel, lCounter  AS LONG
         LOCAL lCustomColor() AS LONG
         LOCAL pitem AS PROPERTYITEM PTR
         LOCAL sz AS ASCIZ * 255
    
        'display the appropriate common dialog depending on what type
        'of chooser is associated with the property
        ' get current listbox selection
        cursel = sendmessage ( hlist, %LB_GETCURSEL,0,0)
        sendmessage ( hlist, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
        lBoxSelText = TRIM$(sz)
        pitem = sendmessage ( hList, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
        'First check for the Choose Color dialog...
        SELECT CASE @pItem.nItemType
            CASE %PIT_COLOR
    
                currClr = @pItem.curValue
    
                IF  currClr > "" THEN
    
                    'parse the property's current color value
                    currClr = LTRIM$(currClr,"RGB(")
                    currClr = RTRIM$(currClr,")")
    
                    initClr = RGB(VAL(PARSE$(currClr,1)), _
                                 VAL(PARSE$(currClr,2)),  _
                                 VAL(PARSE$(currClr,3)))
                ELSE
                    'use a default instead
                    initClr = RGB( 255,128,128 )
                END IF
    
                ColorSpec.lStructSize  = LEN(ColorSpec)
                ColorSpec.hwndOwner    = hList
                ColorSpec.lpCustColors = pColors
                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)
    
                    'Note order of RGB, COLORREF 0x00bbggrr
                    clrStr = "RGB(" + TRIM$(STR$(VAL("&H" + RIGHT$(ClrStr,2)))) + _
                                "," + TRIM$(STR$(VAL("&H" + MID$  (ClrStr,3,2)))) + _
                                "," + TRIM$(STR$(VAL("&H" + LEFT$ (ClrStr,2)))) + ")"
                    @pItem.curValue = clrStr
    
                    'Call ShowWindow( ghButton,%SW_HIDE )
    
                 END IF
    
            CASE %PIT_FILE
                'Next check for the Open File Dialog...
    
                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|"
    
                IF @pItem.curValue = "none" THEN
                   s = "" ' filename
                ELSE
                   s = @pItem.curValue
                END IF
    
                'use simple Open dialog for demo...
                lresult = OpenFileDialog(getparent(hlist), "Select File:", s, CURDIR$, zTxt,"BMP", _
                                      %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_LONGNAMES)
                IF lresult THEN
                    @pItem.curValue = s ' filename
                END IF
    
            'Last, check for the ChooseFont() dialog...
            CASE %PIT_FONT
                DIM cf AS CHOOSEFONTAPI
                DIM lfFont AS LOGFONT
                LOCAL tmpi AS PROPERTYITEM
                LOCAL ptmpi AS PROPERTYITEM PTR
                LOCAL pfcs AS CHOOSEFONTAPI PTR
                LOCAL lbold, litalic, lunderline AS LONG
    
                cf.lStructSize = SIZEOF(cf)
                cf.hWndOwner   = getparent(hlist)
                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
                    sOwner = @pitem.PropName
                    @pItem.curValue = lfFont.lfFaceName
                    '@pitem.tlf = lfFont
    
                    ' if there is a RO Property called FontSize, populate it
                    ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTSIZE) ' as PROPERTYITEM PTR
                    IF ptmpi = 0 THEN EXIT SELECT
                    IF @ptmpi.nItemType <> %PIT_RO THEN EXIT SELECT
                    @ptmpi.curValue = TRIM$(STR$(cf.ipointsize/10))
    
                    ' if there is a RO property called FontAtts owned by the font control, , populate it
                    ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTATTS)
    '                ptmpi = sendmessage ( hlist, %WM_USER + %our_get_property, VARPTR(sz), 0 )
                    IF ptmpi = 0 THEN EXIT SELECT
                    IF @ptmpi.nItemType <> %PIT_RO THEN EXIT SELECT
                    s = ""
                    lbold = 0: lItalic = 0: lUnderLine = 0
                    litalic = lfFont.lfItalic
                    IF litalic <> 0 THEN
                        s = s + ", italic"
                    END IF
                    lUnderline = lfFont.lfUnderline
                    IF lUnderline <> 0 THEN s = s + ", underline"
                    IF lfFont.lfWeight > 699  THEN
                        s = s + ", bold"
                        lbold = %TRUE
                    END IF
                    'just ignoring strikeout.
                    IF LEFT$(s,1) = "," THEN s = MID$(s,3)
                    @ptmpi.curValue = s
    
                    ' if there is a RO property called FontColor, populate it
                    ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTCOLOR)
                    IF ptmpi = 0 THEN EXIT SELECT
                    IF @ptmpi.nItemType <> %PIT_RO THEN EXIT SELECT
                    @ptmpi.curValue = RGB2Str(cf.RGBCOLORS)
                END IF
        END SELECT
        CALL InvalidateRect( hList,BYVAL %NULL,1)
    '    Call ShowWindow( ghButton,%SW_HIDE )
        CALL UpdateWindow ( hList )
    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
    
    '-------------------------------------------------------------------------
    '' SuperClassed ListBox Control Procedure:
    '-------------------------------------------------------------------------
    CALLBACK FUNCTION ListBoxProc
    
        LOCAL lBoxSelText AS STRING
        STATIC OldProc AS LONG, OffsetWndExtra AS LONG
        LOCAL sz AS ASCIZ * 64
        LOCAL psz AS ASCIZ PTR
        LOCAL cursel, hDC, nindex AS LONG
        LOCAL r, rc, rc2, rectfull AS rect
        LOCAL pt AS POINTAPI
        STATIC hbrush, hCursorSize, hcursorarrow, hcombo, hedit, hednum, hbutton, hfont, hinst AS DWORD
        LOCAL p_item, q_item, r_item AS PROPERTYITEM PTR
        LOCAL h, i, n            AS LONG
        STATIC pitem, ppty    AS propertyitem PTR
    
        STATIC nDivider       AS INTEGER
        STATIC nDivTop        AS INTEGER
        STATIC nDivBtm        AS INTEGER
        STATIC nOldDivX       AS INTEGER
        STATIC nLastBox       AS INTEGER
        STATIC bTracking      AS LONG
        STATIC bDivIsSet      AS INTEGER
        DIM Ccolor(0 TO 15)   AS STATIC LONG
        LOCAL lpDs            AS DRAWITEMSTRUCT PTR
        LOCAL pdw             AS DWORD PTR
        LOCAL newStr AS ASCIIZ*255
        LOCAL tTM AS TEXTMETRIC
    
        '
        ' message from  CreateSuperClass to give us the WNDPROC for the base class
        IF CBHNDL = 0 THEN
            OldProc = CBWPARAM
            OffsetWndExtra = CBLPARAM
            EXIT FUNCTION
        END IF
        '
        SELECT CASE CBMSG
    
            CASE %WM_CREATE
                hCursorArrow =  LoadCursor( %NULL, BYVAL %IDC_ARROW )
                hinst = getmodulehandle(BYVAL 0)
                hCursorSize  =  LoadCursor( %NULL, BYVAL %IDC_SIZEWE )
                bTracking = %FALSE
                nDivider  = 0
                bDivIsSet = %FALSE
                '  Create the controls that will need to edit the Properties with.
                '  They are all hidden for now and resized later.
                hButton = CreateWindowEx(0,"BUTTON","", _
                                          %WS_CHILD OR %WS_CLIPSIBLINGS OR %BS_PUSHBUTTON OR %SS_CENTERIMAGE, _
                                          0,0,8,12, _
                                          CBHNDL, %IDC_BUTTON, hInst, BYVAL %NULL)
    
                hCombo  = CreateWindowEx(0,"COMBOBOX", "", _
                                          %WS_CHILD OR %CBS_DROPDOWNLIST OR %CBS_NOINTEGRALHEIGHT, _
                                          0,0,10,100, _
                                          CBHNDL, %IDC_COMBO, hInst, BYVAL %NULL)
    
                hEdit   = CreateWindowEx(0,"EDIT", "True", _
                                          %WS_CHILD OR %WS_CLIPSIBLINGS OR %ES_LEFT OR %ES_AUTOHSCROLL OR %WS_BORDER, _
                                          0,0,10,20, _
                                          CBHNDL, %IDC_EDIT, hInst, BYVAL %NULL)
    
                hEdNum   = CreateWindowEx(0,"EDIT", "", _
                                          %WS_CHILD OR %WS_CLIPSIBLINGS OR %ES_LEFT OR %ES_NUMBER OR _
                                          %ES_AUTOHSCROLL OR %WS_BORDER, _
                                          0,0,10,20, _
                                          CBHNDL, %IDC_EDNUM, hInst, BYVAL %NULL)
                CALL InitializeCustomColors( VARPTR(Ccolor(0)))
    
            CASE %WM_VSCROLL
                 CALL ShowWindow( hButton,%SW_HIDE ) ' get rid of button
            CASE %WM_SETFONT            ' NB SetFont does not return a value
                hfont = CBWPARAM
                CALL SendMessage( hEdit, %WM_SETFONT, hFont, 0 )
                CALL SendMessage( hEdNum, %WM_SETFONT, hFont, 0 )
                CALL SendMessage( hCombo, %WM_SETFONT, hFont, 0 )
    
            'Catch the Combo,Edit,Button child control notifications here...
    
            CASE %WM_COMMAND
                cursel = sendmessage ( CBHNDL, %LB_GETCURSEL,0,0)
                sendmessage ( CBHNDL, %LB_GETTEXT, cursel, VARPTR(sz)) ' get selected text = propertyname
                lBoxSelText = TRIM$(sz)
                pitem = sendmessage ( CBHNDL, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
                SELECT CASE CBCTL
                       CASE %IDC_COMBO
                            IF (CBCTLMSG = %CBN_SELCHANGE) THEN
                                LOCAL selStr AS ASCIIZ*255
                                IF hCombo <> 0  THEN
                                  ' idx& = SendMessage( hCombo, %CB_GETCURSEL ,0 ,0 )
                                   CALL SendMessage( hCombo, %CB_GETLBTEXT, _
                                                     SendMessage( hCombo, %CB_GETCURSEL ,0 ,0 ), _
                                                     VARPTR(selStr) )
                                   @pItem.curValue = selStr
                                END IF
                            END IF
    
                       CASE %IDC_EDIT
                            IF (CBCTLMSG = %EN_CHANGE) THEN
                                n  = SendMessage(hEdit, %WM_GETTEXTLENGTH, 0, 0) + 1
                                newStr = SPACE$(n)
                                CALL SendMessage(hEdit, %WM_GETTEXT, n, VARPTR(newStr))
                                IF pitem <> 0 THEN ' no items exist during initialisation!
                                    @pItem.curValue = newStr
                                END IF
                            END IF
    
                       CASE %IDC_EDNUM
                            IF (CBCTLMSG = %EN_CHANGE) THEN
                                n = SendMessage(hEdNum, %WM_GETTEXTLENGTH, 0, 0) + 1
                                newStr = SPACE$(n)
                                CALL SendMessage(hEdNum, %WM_GETTEXT, n, VARPTR(newStr))
                                IF pitem <> 0 THEN ' no items exist during initialisation!
                                    @pItem.curValue = newStr
                                END IF
                            END IF
    
                       CASE %IDC_BUTTON
                            IF (CBCTLMSG = %BN_CLICKED) THEN
                                cursel = sendmessage ( CBHNDL, %LB_GETCURSEL,0,0)
                                CALL OnButtonClicked( CBHNDL, VARPTR(Ccolor(0)))
                                CALL ShowWindow( hButton,%SW_HIDE ) ' get rid of button
                            END IF
    
                END SELECT
    
            CASE %WM_LBUTTONDOWN
                IF hCombo  <> 0 THEN CALL ShowWindow( hCombo,  %SW_HIDE )
                IF hEdit   <> 0 THEN CALL ShowWindow( hEdit,   %SW_HIDE )
                IF hEdNum  <> 0 THEN CALL ShowWindow( hEdNum,  %SW_HIDE )
                IF hButton <> 0 THEN CALL ShowWindow( hButton, %SW_HIDE )
    
                '-----------------------[ Splitter ]-----------------------
                pt.x = LOWRD(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                IF ((pt.x >= nDivider-5) AND (pt.x <= nDivider+5)) THEN
                    'if mouse clicked on divider line, then start resizing
                    CALL SetCursor(hCursorSize)
    
                    CALL GetWindowRect( CBHNDL ,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( CBHNDL ,rc )
                    bTracking = %TRUE
    
                    nDivTop   = rc.ntop
                    nDivBtm   = rc.nbottom
                    nOldDivX  = pt.x
    
                    CALL InvertLine( CBHNDL, nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
    
                    'capture the mouse
                    CALL SetCapture(CBHNDL)
    
                END IF
    
    
            CASE %WM_MOUSEMOVE
                pt.x = LOWRD(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                'move divider line to the mouse position
                'if columns are currently being resized
                IF bTracking = %TRUE  THEN
    
                    'remove old divider line
                    CALL InvertLine( CBHNDL, nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )
    
                    'draw new divider line
                    CALL InvertLine( CBHNDL, 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(CBLPARAM)
                pt.y = HIWRD(CBLPARAM)
    
                '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( CBHNDL, pt.x ,nDivTop ,pt.x ,nDivBtm )
    
    
                    'set the divider position to the new value
                    nDivider = pt.x
    
                    'Self paint the ListBox control...
                    CALL InvalidateRect(CBHNDL ,BYVAL %NULL, 1)
                    CALL UpdateWindow(CBHNDL)
    
                END IF
    
               CASE %WM_CAPTURECHANGED
                    IF CBLPARAM <> getparent(CBHNDL) THEN
                        IF bTracking = %TRUE THEN
                            bTracking = %FALSE
                            CALL ReleaseCapture()
                            CALL ClipCursor( BYVAL %NULL )
                            CALL InvalidateRect(CBHNDL ,BYVAL %NULL, 1)
                            CALL UpdateWindow(CBHNDL)
                        END IF
                    END IF
               '---------------------[ end of splitter ]------------------
                '---
    
            ' user messages
            CASE %WM_USER + %our_lb_selchange ' sent when LB_SELCHANGE rec'd by parent
                curSel = SendMessage( CBHNDL, %LB_GETCURSEL, 0, 0 )
                CALL OnSelChange(CBHNDL, hcombo, hbutton, hedit, hednum, ndivider)
    
            CASE %WM_USER + %our_DRAWITEM ' parent has rec'd a WM_DRAWITEM msg
                lpDs = CBLPARAM
                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
                sendmessage ( CBHNDL, %LB_GETTEXT, nIndex, VARPTR(sz)) ' get selected text = propertyname
                lBoxSelText = TRIM$(sz)
                pitem = sendmessage ( CBHNDL, %WM_USER + %our_get_property, VARPTR(sz), 0 ) ' get pointer to item structure
                IF  nIndex  > -1  THEN
                    'draw two rectangles, one for each row column
                    ' if the item is r/o, use slightly darker color
                        hBrush = CreateSolidBrush( RGB(200,200,200) )
    '                else
    '                    hBrush = CreateSolidBrush( RGB(192,192,192) )
    '                end if
                    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
                    sz = @pItem.propName
                    IF @pitem.nItemType = %PIT_RO THEN sz = "..." + sz
                    CALL DrawText( @lpDs.hDC , sz, _
                                   LEN(sz), _
                                   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
                    ' if the item is s color then
                    CALL DrawText(@lpDs.hDC , @pItem.curValue, _
                                  LEN(@pItem.curValue), _
                                  rc, %DT_LEFT OR %DT_SINGLELINE )
                    ' if the item is a color then draw a solid block of color at RH end of 2nd rect
                    IF (@pitem.subtype = %PITS_FONTCOLOR) OR (@pitem.nItemtype = %PIT_COLOR) THEN
                        n = Str2RGB(TRIM$(@pitem.CurValue))
                        hBrush = CreateSolidBrush( n)
                        rc.nleft   = rc.nright   - 20
                        rc.ntop    = rc.ntop     - 1
                        rc.nright  = rc.nright   - 5
                        rc.nbottom = rc.nbottom  - 8
                        CALL FillRect(@lpDs.hDC , rc, hBrush )
                        CALL DrawEdge(@lpDs.hDC , rc,  %EDGE_SUNKEN,%BF_SOFT )
                        CALL DeleteObject(hBrush)
                    END IF
                END IF
    
                '<insert here>  Add some kind of item focus rect
    
                FUNCTION = %TRUE
                EXIT FUNCTION
    
            CASE %WM_USER + %our_add_property
                pdw = CBLPARAM
                p_item = CBLPARAM
                ' grab memory to hold new property and ititialise to zeros
                h = GlobalAlloc ( %GPTR, SIZEOF(PropertyItem))
                ' move property details into memory
                movememory ( BYVAL h, BYVAL pdw, SIZEOF(PROPERTYITEM))
                ' add it into list at end
                IF ppty = %NULL THEN ' empty list
                    ppty = h
                ELSE
                    p_item = ppty
                    WHILE @p_item.fptr <> %NULL
                        p_item = @p_item.fptr
                    WEND
                    @p_item.fptr = h
                END IF
                q_item = h
                sz = @q_item.propname
                pitem = q_item          ' pitem is static!
                CALL SendMessage(CBHNDL,%LB_ADDSTRING,0,VARPTR(sz))
                EXIT FUNCTION
    
            CASE %WM_USER + %our_get_property ' wparam has a ptr to propertyname
                ' find property by name
                p_item = ppty
                IF p_item = %NULL THEN EXIT FUNCTION ' empty list
                psz = CBWPARAM
                WHILE TRIM$(@p_item.propname)  <> TRIM$(@psz)
                    p_item = @p_item.fptr
                    IF p_item = %NULL THEN EXIT FUNCTION ' return null pointer
                WEND
                ' return msg with pointer to it
                FUNCTION = p_item ' return pointer to property
                EXIT FUNCTION
                'sendmessage ( hParent, %WM_USER + %our_ispty, 0, p_item)
    
            CASE %WM_USER + %our_set_property ' wparam has a ptr to propertyitem to replace
                ' find property by name
                p_item = ppty
                IF p_item = %NULL THEN EXIT FUNCTION ' empty list
                q_item = CBWPARAM
                WHILE TRIM$(@p_item.propname) <> TRIM$(@q_item.PropName)
                    p_item = @p_item.fptr
                    IF p_item = %NULL THEN
                        FUNCTION = -1
                        EXIT FUNCTION
                    END IF
                WEND
                @q_item.fptr = @p_item.fptr
                @p_item = @q_item
                FUNCTION = p_item
                EXIT FUNCTION
    
            CASE %WM_USER + %our_get_property_count
                ' count properties in list
                p_item = ppty
                IF p_item = %NULL THEN EXIT FUNCTION ' return zero
                WHILE %TRUE
                    INCR i
                    p_item = @p_item.fptr
                    IF p_item = %NULL THEN
                        FUNCTION = i
                        EXIT FUNCTION
                    END IF
                WEND
            '
            CASE %WM_DESTROY
                ' deallocate memory in property linked list
                p_item = ppty
                WHILE p_item <> %null
                    q_item = p_item
                    p_item = @p_item.fptr
                    globalfree( BYVAL q_item )
                WEND
                ppty = %NULL
                '
                CALL PostQuitMessage( 0 )
        END SELECT
    
        ' if the message was received as a user message, it is not processed further
        IF (CBMSG > %WM_USER) AND ( CBMSG < %WM_USER + %our_msg_max) THEN EXIT FUNCTION
        '
        FUNCTION = CallWindowProc(OldProc, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    
    
    '--------------------------------------------------------------------------
    ' InvertLine()
    '--------------------------------------------------------------------------
    SUB InvertLine( BYVAL hList AS DWORD, 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(hList)
    
        '*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(hList, hDC)
    
    END SUB
    
    DDT code example:
    
    
    Code:
    #COMPILE EXE
    #INCLUDE "WIN32API.INC"
    #INCLUDE "COMDLG32.INC"
    #INCLUDE "COMMCTRL.INC"
    #INCLUDE "PROPCON.INC"
    '---
    %IDC_DEBUG_BN = 1007
    
    '--------------------------------------------------------------------------
    ' User Designed Custom Control : Properties List
    '
    ' example of how to call it from DDT
    ' Chris Holbrook 7-Feb-2008
    '--------------------------------------------------------------------------
    ' This sub is outside the custom control so it needs to know where the CC is
    ' for which purpose the parent hWnd and control id are passed in
    SUB InitializePropertyItems( hOwner AS DWORD, lCtlId AS LONG)
        LOCAL pi AS propertyitem
    
    
        pi.propName  =  "Dialog Id"
        pi.curValue  =  "DKW application..."
        pi.nItemType =  %PIT_EDIT
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Control Id"
        pi.curValue  =  "1"
        pi.nItemType =  %PIT_EDIT
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Control Type"
        pi.curValue  =  "Label"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "Label|TextBox|CheckBox|ListBox|ListView|Button|GDIPImage|"
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Visible"
        pi.curValue  =  "true"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "true|false|"
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Background Color"
        pi.curValue  =  "RGB(255,255,0)"
        pi.nItemType =  %PIT_COLOR
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Font"
        pi.curValue  =  "MS San Sarif"
        pi.nItemType =  %PIT_FONT
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "FontAtts
        pi.curValue  =  "MS San Sarif"
        pi.nItemType =  %PIT_RO
        pi.subtype   =  %PITS_FONTATTS
        pi.sOwner    =  "Font"
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "FontSize"
        pi.curValue  =  "MS San Sarif"
        pi.nItemType =  %PIT_RO
        pi.subtype   =  %PITS_FONTSIZE
        pi.sOwner    =  "Font"
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "FontColor"
        pi.curValue  =  "MS San Sarif"
        pi.nItemType =  %PIT_RO
        pi.subtype   =  %PITS_FONTCOLOR
        pi.sOwner    =  "Font"
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  = "Text"
        pi.curValue  =  "Control id"
        pi.nItemType =  %PIT_EDIT
        pi.subtype   =  %PITS_NULL
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Location X"
        pi.curValue  =  "10"
        pi.nItemType =  %PIT_EDNUM
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Location Y"
        pi.curValue  =  "90"
        pi.nItemType =  %PIT_EDNUM
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Width"
        pi.curValue  =  "300"
        pi.nItemType =  %PIT_EDNUM
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Height"
        pi.curValue  =  "200"
        pi.nItemType =  %PIT_EDNUM
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Vert. Align"
        pi.curValue  =  "CENTER"
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "CENTER|TOP|BOTTOM|"
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "ImageFile"
        pi.curValue  =  "none"
        pi.nItemType =  %PIT_FILE
        pi.cmbItems  =  ""
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
        pi.propName  =  "Crop Image to frame"
        pi.curValue  =  ""
        pi.nItemType =  %PIT_COMBO
        pi.cmbItems  =  "yes|no|"
        CONTROL SEND howner, lCtlId, %WM_USER + %our_add_property, 0, VARPTR(pi)
    
    END SUB
    
    
    '--------------------------------------------------------------------------
    ' Load 16 Custom colors up for our ChooseColor() Dialog
    '--------------------------------------------------------------------------
    'SUB InitializeCustomColors( pColors AS DWORD)
    '
    '  LOCAL lCounter AS LONG
    '  LOCAL pl       AS LONG PTR
    '  'load your custom colors...
    '  RANDOMIZE TIMER
    '  pl = pColors
    '  FOR lCounter = 0 TO 15
    '    'example colors,
    '    @pl = RND(0,16777215)
    '    INCR pl
    '  NEXT
    '
    'END SUB
    
    %IDD_DIALOG1         =  101
    #PBFORMS END CONSTANTS
    
    DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
    DECLARE FUNCTION SampleListView(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL lColCnt AS LONG, BYVAL lRowCnt AS LONG) AS LONG
    DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    #PBFORMS DECLARATIONS
    
    FUNCTION PBMAIN()
    
        InitCommonControls
    
        ShowDIALOG1 %HWND_DESKTOP
    END FUNCTION
    '-----------------------------------------------------------------------------------------------------
    CALLBACK FUNCTION ShowDIALOG1Proc()
    
        STATIC hlist, hfont, hwndBn         AS DWORD
        LOCAL lpMs            AS MEASUREITEMSTRUCT PTR
        LOCAL psz AS ASCIZ PTR
        LOCAL result, nrows, i AS LONG
        LOCAL sz AS ASCIZ * 255
        LOCAL pitem          AS PROPERTYITEM PTR
        LOCAL s AS STRING
    
        SELECT CASE AS LONG CBMSG
    
            CASE %WM_INITDIALOG
                hFont = MakeFont("r_ansi" , 8)
                CONTROL SEND CBHNDL, %IDC_LISTBOX, %WM_SETFONT, hFont, 0
                CONTROL SEND CBHNDL, %IDC_LISTBOX, %LB_SETITEMHEIGHT, 0, 20 ' try values around (pointsize * 2) + 4
                InitializePropertyItems(CBHNDL, %IDC_LISTBOX)
    
            CASE %WM_NCACTIVATE
                STATIC hWndSaveFocus AS DWORD
                IF ISFALSE CBWPARAM THEN
                    hWndSaveFocus = GetFocus()
                ELSEIF hWndSaveFocus THEN
                    SetFocus(hWndSaveFocus)
                    hWndSaveFocus = 0
                END IF
    
            CASE %WM_DRAWITEM
    
                CONTROL SEND CBHNDL, %IDC_LISTBOX, %WM_USER + %our_DRAWITEM, CBWPARAM, CBLPARAM
    
                FUNCTION = %TRUE
                EXIT FUNCTION
                
            CASE %LBS_NOTIFY
                
                
            CASE %WM_COMMAND
                'ListBox control notifications...
                SELECT CASE CBCTL
                                                                          
                   CASE %IDC_LISTBOX
                        SELECT CASE HIWRD(CBWPARAM)
                               CASE %LBN_SELCHANGE, %LBN_SELCANCEL
                                   ' nudge the listbox control
                                   CONTROL SEND CBHNDL, %IDC_LISTBOX, %WM_USER + %our_lb_selchange, 0, 0
                        END SELECT
    
                   CASE %IDC_DEBUG_BN
                        CONTROL SEND CBHNDL, %IDC_LISTBOX, %WM_USER + %our_get_property_count,0,0 TO result
                        ? "there are" + STR$(result) + " properties in the list"
                        ' work through listbox getting each property in turn,
                        ' requesting its values & formatting them for display
                        CONTROL SEND CBHNDL, %IDC_LISTBOX, %LB_GETCOUNT,0,0 TO nrows
                        FOR i = 1 TO nrows
                            CONTROL SEND CBHNDL, %IDC_LISTBOX, %LB_GETTEXT, i, VARPTR(sz)
                            CONTROL SEND CBHNDL, %IDC_LISTBOX, %WM_USER + %our_get_property, VARPTR(sz), 0 TO pitem
                            s = s + "name = " + TRIM$(@pitem.Propname) + "," + _
                                    "CurValue = " + TRIM$(@pitem.CurValue) + ","
                            SELECT CASE @pitem.nitemtype
                                CASE %PIT_COMBO
                                    s = s + "nItemType = COMBO"
                                CASE %PIT_EDIT
                                    s = s + "nItemType = EDIT"
                                CASE %PIT_COLOR
                                    s = s + "nItemType = COLOR"
                                CASE %PIT_FONT
                                    s = s + "nItemType = FONT"
                                CASE %PIT_FILE
                                    s = s + "nItemType = FILE"
                                CASE %PIT_EDNUM
                                    s = s + "nItemType = NUMBER"
                            END SELECT
                            s = s + ",cmbitems = " + TRIM$(@pitem.CmbItems) + "," + _
                                    "fptr = " + STR$( @pitem.fptr) + $CRLF
                        NEXT
                        ? s
                END SELECT
            CASE %WM_DESTROY
                deleteObject hfont
        END SELECT
    END FUNCTION
    
    '-----------------------------------------------------------------------------------------
    FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
                        
    #PBFORMS BEGIN DIALOG %IDD_DIALOG1->->
        LOCAL hDlg  AS DWORD
    
        IF ISFALSE(CreateSuperClass("LISTBOX","OurLB", CODEPTR(ListBoxProc), 4)) THEN EXIT FUNCTION
    
        DIALOG NEW PIXELS, hParent, "PROPCON from DDT", 100, 100, 350, 225, %WS_SYSMENU TO hDlg
    
                '  Create the OwnerDraw List box for our control properties...
                CONTROL ADD "OurLB", hdlg, %IDC_LISTBOX, "", _
                         10,10,325,150, _
                         %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, %ws_ex_clientedge
    
        CONTROL ADD BUTTON, hDlg, %IDC_DEBUG_BN, "Button1", 270, 170, 40, 20
    #PBFORMS END DIALOG
    
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
    
    #PBFORMS BEGIN CLEANUP %IDD_DIALOG1
    #PBFORMS END CLEANUP
    
        FUNCTION = lRslt
    END FUNCTION
    Last edited by Chris Holbrook; 8 Feb 2008, 04:01 PM. Reason: enhancements

    Comment


    • #3
      2009 version

      This version has a couple of changes, mainly to remove static/global variables so that more than one properties control can be used in the same dialog.

      Also it is now all SDK code, though the example shows how to call it from DDT.

      New messages instruct the control on background colour and font, the latter being handled entirely within the control.

      Here is the DDT demo application:

      Code:
      '--------------------------------------------------------------------------
      ' User Designed Custom Control : Properties List
      '
      ' example of how to call it from DDT
      ' Chris Holbrook 11-Dec-2009
      '
      #compile exe
      #include "WIN32API.INC"
      #include "COMDLG32.INC"
      #include "COMMCTRL.INC"
      #include "PROPCON2.INC"
      '---
      %IDC_VIEW_BN = 2707
      %IDC_START_BN = 2708
      %IDC_CLEANUP_BN = 2709
      %IDC_LISTBOX = 2710
      
      '--------------------------------------------------------------------------
      ' This sub is outside the custom control so it needs to know where the CC is
      ' for which purpose the parent hWnd and control id are passed in
      sub InitializePropertyItems( hOwner as dword, lCtlId as long)
          local pi as propertyitem
          local i as long
      
          pi.propName  =  "Beast Id"
          pi.curValue  =  "1"
          pi.nItemType =  %PIT_EDIT
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Animal"
          pi.curValue  =  "Duck"
          pi.nItemType =  %PIT_COMBO
          pi.cmbItems  =  "Goat|Sheep|Cow|Duck|Octopus|Platypus|Pussytat|"
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Visible"
          pi.curValue  =  "true"
          pi.nItemType =  %PIT_COMBO
          pi.cmbItems  =  "true|false|"
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Background Color"
          pi.curValue  =  "RGB(255,255,0)"
          pi.nItemType =  %PIT_COLOR
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Font"
          pi.curValue  =  "MS San Sarif"
          pi.nItemType =  %PIT_FONT
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "FontAtts
          pi.curValue  =  "MS San Sarif"
          pi.nItemType =  %PIT_RO
          pi.subtype   =  %PITS_FONTATTS
          pi.sOwner    =  "Font"
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "FontSize"
          pi.curValue  =  "Consolas"
          pi.nItemType =  %PIT_RO
          pi.subtype   =  %PITS_FONTSIZE
          pi.sOwner    =  "Font"
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "FontColor"
          pi.curValue  =  "MS San Sarif"
          pi.nItemType =  %PIT_RO
          pi.subtype   =  %PITS_FONTCOLOR
          pi.sOwner    =  "Font"
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  = "Text"
          pi.curValue  =  "Control id"
          pi.nItemType =  %PIT_EDIT
          pi.subtype   =  %PITS_NULL
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Height"
          pi.curValue  =  "10"
          pi.nItemType =  %PIT_EDNUM
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Length"
          pi.curValue  =  "90"
          pi.nItemType =  %PIT_EDNUM
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Weight"
          pi.curValue  =  "300"
          pi.nItemType =  %PIT_EDNUM
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Alignment"
          pi.curValue  =  "CENTER"
          pi.nItemType =  %PIT_COMBO
          pi.cmbItems  =  "CENTER|TOP|BOTTOM|"
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "ImageFile"
          pi.curValue  =  "none"
          pi.nItemType =  %PIT_FILE
          pi.cmbItems  =  ""
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
          pi.propName  =  "Crop Image to frame"
          pi.curValue  =  ""
          pi.nItemType =  %PIT_COMBO
          pi.cmbItems  =  "yes|no|"
          control send howner, lCtlId, %wm_user + %our_add_property, 0, varptr(pi)
      
      end sub
      
      %IDD_DIALOG1         =  101
      
      '-----------------------------------------------------------------------------------------------------
      callback function FormPPTCallback()
      
          static hlist, hfont, hwndBn         as dword
          local lpMs            as MEASUREITEMSTRUCT ptr
          local psz as asciz ptr
          local result, nrows, i as long
          local sz as asciz * 255
          local pitem          as PROPERTYITEM ptr
          local s as string
      
          select case as long cbmsg
      
              case %wm_initdialog
                  s = "courier ps|9|I"
                  psz = strptr(s)
                  control send cbhndl, %IDC_LISTBOX, %wm_user + %our_setfont, psz, 0
                  control send cbhndl, %IDC_LISTBOX, %wm_user + %our_SetBgColor, %rgb_lightblue, 0
                  control send cbhndl, %IDC_LISTBOX, %LB_SETITEMHEIGHT, 0, 20 ' try values around (pointsize * 2) + 4
      
              case %wm_ncactivate
                  static hWndSaveFocus as dword
                  if isfalse cbwparam then
                      hWndSaveFocus = GetFocus()
                  elseif hWndSaveFocus then
                      SetFocus(hWndSaveFocus)
                      hWndSaveFocus = 0
                  end if
      
              case %wm_drawitem
                  if cb.ctl = %IDC_LISTBOX then
                      control send cbhndl, %IDC_LISTBOX, %wm_user + %our_DRAWITEM, cbwparam, cblparam
                      function = %TRUE
                      exit function
                  end if
      
              case %lbs_notify
      
              case %wm_command
                  select case cbctl
                     '
                     case %IDC_LISTBOX
                          select case hiwrd(cbwparam)
                                 case %lbn_selchange, %lbn_selcancel
                                     ' nudge the listbox control
                                     control send cbhndl, %IDC_LISTBOX, %wm_user + %our_lb_selchange, 0, 0
                          end select
                     '
                     case %IDC_VIEW_BN
                          control send cbhndl, %IDC_LISTBOX, %wm_user + %our_get_property_count,0,0 to result
                          ? "there are" + str$(result) + " properties in the list"
                          ' work through listbox getting each property in turn,
                          ' requesting its values & formatting them for display
                          control send cbhndl, %IDC_LISTBOX, %LB_GETCOUNT,0,0 to nrows
                          for i = 1 to nrows
                              control send cbhndl, %IDC_LISTBOX, %LB_GETTEXT, i, varptr(sz)
                              control send cbhndl, %IDC_LISTBOX, %wm_user + %our_get_property, varptr(sz), 0 to pitem
                              s = s + "name = " + trim$(@pitem.Propname) + "," + _
                                      "CurValue = " + trim$(@pitem.CurValue) + ","
                              select case @pitem.nitemtype
                                  case %PIT_COMBO
                                      s = s + "nItemType = COMBO"
                                  case %PIT_EDIT
                                      s = s + "nItemType = EDIT"
                                  case %PIT_COLOR
                                      s = s + "nItemType = COLOR"
                                  case %PIT_FONT
                                      s = s + "nItemType = FONT"
                                  case %PIT_FILE
                                      s = s + "nItemType = FILE"
                                  case %PIT_EDNUM
                                      s = s + "nItemType = NUMBER"
                              end select
                              s = s + ",cmbitems = " + trim$(@pitem.CmbItems) + "," + _
                                      "fptr = " + str$( @pitem.fptr) + $crlf
                          next
                          ? s
                  end select
              case %wm_destroy
                  font end hfont
          end select
      end function
      
      '-----------------------------------------------------------------------------------------
      function FormPPTDD(byval hParent as dword) as long
          local lRslt as long
          local hDlg  as dword
      
          if isfalse(CreateSuperClass("LISTBOX","OurLB", codeptr(ListBoxProc), 4)) then exit function
      
          dialog new pixels, hParent, "PROPCON from DDT", 100, 100, 350, 225, %ws_sysmenu to hDlg
      
                  '  Create the OwnerDraw List box for our control properties...
                  control add "OurLB", hdlg, %IDC_LISTBOX, "", _
                           10,10,325,150, _
                           %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, %ws_ex_clientedge
          InitializePropertyItems(hDlg, %IDC_LISTBOX)
      
          control add button, hDlg, %IDC_VIEW_BN, "See all properties", 240, 200, 100, 20
          dialog show modal hDlg, call FormPPTCallBack to lRslt
      
          function = lRslt
      end function
      '--------------------------------------------------------------
      function pbmain()
      
          InitCommonControls
      
          FormPPTDD %hwnd_desktop
      end function
      Here is the Include file:
      Code:
      '--------------------------------------------------------------------------------------------
      ' Module:  PROPCON.inc
      ' Desc:    Properties List control
      ' Interface:
      '          The control is driven by WM_USER messages, see list in code
      '          The developer also has to handle the WM_MEASUREITEM message as shown.
      ' Issues:
      '          1. lack of thorough testing
      '          2. WM_MEASUREITEM
      '
      ' Purpose: a standalone control for managing a properties list
      ' History: Listbox handling code borrowed from Jules Marchildon's post of 2001 , not changed much
      ' Date:    7-FEB-2008  updated 11-DEC-2009
      ' Name:    Chris Holbrook
      ' Changes 11-DEC-2009
      '          The font is generated within the control in response to the
      '              %wm_user + %our_setfont message, whose wparam is a strptr to
      '              an string in the form "fontname|pointsize|attributes", where
      '                  fontname is the font name
      '                  pointsize is the pointsize
      '                  attributes is a string containing any combination of I, B, U and S
      '                      for Italic, Bold, Underline and Strikeout resp.
      '          If a font is sent to the control, it is cascaded to the sub-controls.
      '          The control deletes the font and other memory structures in the %wm_destroy handler
      '
      '          This version does not use global or static storage except for the address of the
      '          superclassed wndproc which is considered not to change between instances of the
      '          control
      '
      '--------------------------------------------------------------------------------------------
      
      type PROPERTYITEM
        propName  as asciz   * 32
        sOwner    as asciz   * 32      ' name of property which owns the item
        curValue  as asciiz  *255
        nItemType as integer
        subtype   as long
        cmbItems  as asciiz  *255
        fptr      as propertyitem ptr
        sFileFind as asciz * 255
        sdfltExt  as asciz * 64
      end type
      '
      ' this UDT contains all of the control's static variables
      ' except for the superclassed wndproc address, which
      ' is considered not to change during a single instance of the application
      '
      type tLBInstance      ' statics used by list box proc
          hfont          as dword ' the font handle fo this instance
          BgColor        as dword ' background color for LH column
          hMem           as dword ' handle to memory block containg this UDT
          ppty           as propertyitem ptr
          hCombo         as dword
          hedit          as dword
          hednum         as dword
          hbutton        as dword
          nIndex         as integer
          nDivider       as integer
          nDivTop        as integer
          nDivBtm        as integer
          nOldDivX       as integer
          nLastBox       as integer
          nproperties    as long ' populated by get_property_count
          bTracking      as long
          binitialising  as long
          bDivIsSet      as integer
          Ccolor(0 to 15)   as long
      end type
      
      ' message types - WM_USER offsets
      %our_add_property        = 500
      %our_get_property        = 501
      %our_get_property_count  = 502
      %our_MEASUREITEM         = 503
      %our_drawitem            = 504
      %our_lb_selchange        = 505
      %our_hide_embedded_control = 506
      %our_SetBgColor          = 507
      %our_setfont             = 508
      %our_msg_max             = 509  ' must be highest WM_USER offset + 1
      
      'PIT = property item type, Button is default
      %PIT_COMBO   = 0
      %PIT_EDIT    = 1
      %PIT_COLOR   = 2
      %PIT_FONT    = 3
      %PIT_FILE    = 4
      %PIT_EDNUM   = 5
      %PIT_RO      = 6
      ' subtypes
      %PITS_NULL               = 0
      %PITS_FontAtts           = 1
      %PITS_FontSize           = 2
      %PITS_FontColor          = 3
      %PITS_COLOR              = 4
      '---
      %PP2_LISTBOX = 1000
      %PP2_COMBO   = 1001
      %PP2_BUTTON  = 1002
      %PP2_EDIT    = 1003
      %PP2_EDNUM   = 1004
      %PP2_UCC     = 1005
      %PP2_DEBUG_BN = 1006
      '-------------------------------------------------------------
      ' common functions
      '------------------------------------------------------------------------------
      ' borrowed from Semen Matusovski
      function CreateSuperClass(OldClassName as string, NewClassName as string, lpfnNewWndProc as long, cbWndExtra as long) as long
          local wc as WNDCLASSEX
          local result as long
      
          wc.cbSize = sizeof(wc)
          if GetClassInfoEx(byval 0&, byval strptr(OldClassName), wc) then
              CallWindowProc lpfnNewWndProc, 0, 0, wc.lpfnWndProc, wc.cbWndExtra
              wc.hInstance = GetModuleHandle(byval 0&)
              wc.lpszClassName = strptr(NewClassName)
              wc.lpfnWndProc = lpfnNewWndProc
              wc.cbWndExtra = wc.cbWndExtra + cbWndExtra
              result = RegisterClassEx(wc)
              function = result
          end if
      end function
      
      '----------------------------------------------------------------------------
      sub OnSelChange(hlist as dword, hcombo as dword, hbutton as dword, hedit as dword, _
                      hednum as dword, nDivider as integer)
      
          local cmbitems, lBoxSelText, s as string
          local rc as RECT
          local cursel as long
          local nlastbox as long
          local pitem as PROPERTYITEM ptr
          local sz as asciz * 255
          local i, j, ncount as long
      
          curSel = SendMessage( hList, %LB_GETCURSEL, 0, 0 )
          sendmessage ( hlist, %LB_GETTEXT, cursel, varptr(sz)) ' get selected text = propertyname
          lBoxSelText = sz
          pitem = sendmessage ( hList, %wm_user + %our_get_property, varptr(sz), 0) ' get pointer to item structure
          call SendMessage( hList, %LB_GETITEMRECT, curSel, varptr(rc) )
      
          rc.nleft = nDivider
      
          ' hide any open controls
          if hCombo  <> 0 then call ShowWindow( hCombo,  %sw_hide )
          if hButton <> 0 then call ShowWindow( hButton, %sw_hide )
          if hEdit   <> 0 then call ShowWindow( hEdit,   %sw_hide )
          if hEdNum  <> 0 then call ShowWindow( hEdNum,  %sw_hide )
      
          select case @pItem.nItemType
              case %PIT_COMBO
                  'display the combo box and move it to the new location
                  nLastBox = 0
      
                  if hCombo <> 0 then
                     call MoveWindow( hCombo,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    = trim$(@pItem.cmbItems)
                  lBoxSelText = @pItem.curValue
      
                  call SendMessage( hCombo,%CB_RESETCONTENT, 0,0 )
      
                  nCount = tally(cmbItems,"|")
      
                  for i& = 1 to nCount&
                      s = parse$(cmbItems,"|",i)
                      'add each string to the ComboBox
                      call SendMessage(hCombo, %CB_ADDSTRING, i-1, strptr(s) )
                  next
      
                  call ShowWindow( hCombo,%sw_show )
                  call SetFocus( hCombo )
      
                  'jump to the property's current value in the combo box
                  j = SendMessage(hCombo,%CB_FINDSTRINGEXACT,0,strptr(lBoxSelText) )
                  if  j <> %CB_ERR  then
                      call SendMessage( hCombo,%CB_SETCURSEL, j, 0 )
                  else
                      'there is no current value, so default to first in list
                      call SendMessage( hCombo,%CB_SETCURSEL,0,0 )
                  end if
              '
              case %PIT_EDIT
                  'display edit box
                  nLastBox   = 1
                  rc.nbottom = rc.nbottom - 3
      
                  if hEdit <> 0 then
                     call MoveWindow( hEdit,rc.nleft+1,rc.ntop+1,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
                  end if
      
                  lBoxSelText = @pItem.curValue
      
                  call ShowWindow( hEdit, %sw_show )
                  call SetFocus( hEdit )
      
                  'set the text in the edit box to the property's current value
                  call SendMessage(hEdit, %WM_SETTEXT, 0, strptr(lBoxSelText) )
              '
              case %PIT_EDNUM
                  'display edit box
                  nLastBox   = 1
                  rc.nbottom = rc.nbottom - 3
      
                  if hEdNum <> 0 then
                     call MoveWindow( hEdNum,rc.nleft+1,rc.ntop+1,rc.nright-rc.nleft,rc.nbottom-rc.ntop,1 )
                  end if
      
                  lBoxSelText = @pItem.curValue
      
                  call ShowWindow( hEdNum, %sw_show )
                  call SetFocus( hEdNum )
                  'set the text in the edit box to the property's current value
                  call SendMessage(hEdNum, %WM_SETTEXT, 0, strptr(lBoxSelText) )
              '
              case %PIT_RO
                  ' readonly - no action
              '
              case else
                  'displays a button if the property is a Color/File/Font chooser
                  nLastBox = 2
      
                  if  (rc.nright - rc.nleft) > 25  then
                      rc.nleft   = rc.nright  - 25
                  end if
      
                  rc.nbottom = rc.nbottom - 3
      
                  if hButton <> 0  then
                     call MoveWindow( hButton,rc.nleft,rc.ntop,rc.nRight -rc.nleft, rc.nBottom -rc.ntop, 1 )
                  end if
      
                  call ShowWindow( hButton, %sw_show )
                  call SetFocus( hButton )
                  '---
          end select
      
      end sub
      '-------------------------------------------------------------------------
      ' convert a string with decimal values like "RGB(123,4,255" to a color value
      function Str2RGB ( s as string) as long
          function = rgb ( val(parse$(s,any "(,)",2)), _
                           val(parse$(s,any "(,)",3)), _
                           val(parse$(s,any "(,)",4)) )
      end function
      '----------------------------------------------------------------------------
      function RGB2Str ( lcolor as long ) as string
          local s as string
      
          s = hex$(lcolor,6)
          'Note order of RGB, COLORREF 0x00bbggrr
          s = "RGB(" + trim$(str$(val("&H" + right$(s,2)))) + _
                      "," + trim$(str$(val("&H" + mid$  (s,3,2)))) + _
                      "," + trim$(str$(val("&H" + left$ (s,2)))) + ")"
          function = s
      end function
      '----------------------------------------------------------------------------
      function FindSubProperty ( hWnd as dword, sOwner as string, subType as long) as dword
          local sz as asciz * 255
          local i, n as long
          local pitem as PROPERTYITEM ptr
      
          ' get count of properties
          n = sendmessage( hWnd, %wm_user + %our_get_property_count, 0, 0)
          ' find a property with the requisite Owner & subtype
          for i = 1 to n
              sendmessage ( hWnd, %LB_GETTEXT, i, varptr(sz))
              pitem = sendmessage ( hWnd, %wm_user + %our_get_property, varptr(sz), 0 )
              if trim$(@pitem.sowner) <> trim$(sOwner) then iterate
              if @pitem.Subtype <> subtype then iterate
              function = pitem
              exit function
          next
      end function
      '----------------------------------------------------------------------------
      sub OnButtonClicked(hlist as dword, pColors as dword)
      
           local lBoxSelText, s, sowner    as string
           local initClr        as dword
           local currClr        as asciiz*255
           local clrStr         as asciiz*255
           local ColorSpec      as CHOOSECOLORAPI
           local lResult, cursel, lCounter  as long
           local lCustomColor() as long
           local pitem as PROPERTYITEM ptr
           local sz as asciz * 255
      
          'display the appropriate common dialog depending on what type
          'of chooser is associated with the property
          ' get current listbox selection
          cursel = sendmessage ( hlist, %LB_GETCURSEL,0,0)
          sendmessage ( hlist, %LB_GETTEXT, cursel, varptr(sz)) ' get selected text = propertyname
          lBoxSelText = trim$(sz)
          pitem = sendmessage ( hList, %wm_user + %our_get_property, varptr(sz), 0 ) ' get pointer to item structure
          'First check for the Choose Color dialog...
          select case @pItem.nItemType
              case %PIT_COLOR
      
                  currClr = @pItem.curValue
      
                  if  currClr > "" then
      
                      'parse the property's current color value
                      currClr = ltrim$(currClr,"RGB(")
                      currClr = rtrim$(currClr,")")
      
                      initClr = rgb(val(parse$(currClr,1)), _
                                   val(parse$(currClr,2)),  _
                                   val(parse$(currClr,3)))
                  else
                      'use a default instead
                      initClr = rgb( 255,128,128 )
                  end if
      
                  ColorSpec.lStructSize  = len(ColorSpec)
                  ColorSpec.hwndOwner    = hList
                  ColorSpec.lpCustColors = pColors
                  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)
      
                      'Note order of RGB, COLORREF 0x00bbggrr
                      clrStr = "RGB(" + trim$(str$(val("&H" + right$(ClrStr,2)))) + _
                                  "," + trim$(str$(val("&H" + mid$  (ClrStr,3,2)))) + _
                                  "," + trim$(str$(val("&H" + left$ (ClrStr,2)))) + ")"
                      @pItem.curValue = clrStr
      
                      'Call ShowWindow( ghButton,%SW_HIDE )
      
                   end if
      
              case %PIT_FILE
                  'Next check for the Open File Dialog...
      
                  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|"
      
                  if @pItem.curValue = "none" then
                     s = "" ' filename
                  else
                     s = @pItem.curValue
                  end if
                  'use simple Open dialog for demo...
                  lresult = OpenFileDialog(getparent(hlist), "Select File:", s, curdir$, @pItem.sFileFind, _
                                @pitem.sdfltExt, %ofn_filemustexist or %ofn_hidereadonly or %ofn_longnames)
                  if lresult then
                      @pItem.curValue = s ' filename
                  end if
      
              'Last, check for the ChooseFont() dialog...
              case %PIT_FONT
                  dim cf as CHOOSEFONTAPI
                  dim lfFont as LOGFONT
                  local tmpi as PROPERTYITEM
                  local ptmpi as PROPERTYITEM ptr
                  local pfcs as CHOOSEFONTAPI ptr
                  local lbold, litalic, lunderline as long
      
                  cf.lStructSize = sizeof(cf)
                  cf.hWndOwner   = getparent(hlist)
                  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
                      sOwner = @pitem.PropName
                      @pItem.curValue = lfFont.lfFaceName
                      '@pitem.tlf = lfFont
      
                      ' if there is a RO Property called FontSize, populate it
                      ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTSIZE) ' as PROPERTYITEM PTR
                      if ptmpi = 0 then exit select
                      if @ptmpi.nItemType <> %PIT_RO then exit select
                      @ptmpi.curValue = trim$(str$(cf.ipointsize/10))
      
                      ' if there is a RO property called FontAtts owned by the font control, , populate it
                      ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTATTS)
      '                ptmpi = sendmessage ( hlist, %WM_USER + %our_get_property, VARPTR(sz), 0 )
                      if ptmpi = 0 then exit select
                      if @ptmpi.nItemType <> %PIT_RO then exit select
                      s = ""
                      lbold = 0: lItalic = 0: lUnderLine = 0
                      litalic = lfFont.lfItalic
                      if litalic <> 0 then
                          s = s + ", italic"
                      end if
                      lUnderline = lfFont.lfUnderline
                      if lUnderline <> 0 then s = s + ", underline"
                      if lfFont.lfWeight > 699  then
                          s = s + ", bold"
                          lbold = %TRUE
                      end if
                      'just ignoring strikeout.
                      if left$(s,1) = "," then s = mid$(s,3)
                      @ptmpi.curValue = s
      
                      ' if there is a RO property called FontColor, populate it
                      ptmpi = findSubProperty ( hlist, sOwner, %PITS_FONTCOLOR)
                      if ptmpi = 0 then exit select
                      if @ptmpi.nItemType <> %PIT_RO then exit select
                      @ptmpi.curValue = RGB2Str(cf.RGBCOLORS)
                  end if
          end select
          call InvalidateRect( hList,byval %NULL,1)
          call UpdateWindow ( hList )
      end sub
      '-------------------------------------------------------------------------
      ' Create a Font:
      '-------------------------------------------------------------------------
      function PropMakeFont(byval szfont as dword) as long
          local s, sfont as string
          local psz as asciz ptr
          local hDC as long, CyPixels as long
          local weight, italic, underline, strikeout as dword
          local pointsize as long
      
          psz = szfont
          sfont = @psz
          hDC = GetDC(%hwnd_desktop)
          CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
          ReleaseDC %hwnd_desktop, hDC
          pointsize = val(parse$(sfont,"|",2))
          PointSize = (PointSize * CyPixels) \ 72
          s = parse$(sfont,"|",3)
          weight = %FW_NORMAL
          if instr(s, "B") then weight    = %FW_BOLD
          if instr(s, "I") then italic    = %TRUE
          if instr(s, "U") then underline = %TRUE
          if instr(s, "S") then strikeout = %TRUE
          sfont = parse$(sfont,"|",1)
          function = CreateFont(0 - PointSize, 0, 0, 0, weight, italic, underline, strikeout, _
          %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
          %DEFAULT_QUALITY, %FF_DONTCARE, bycopy sFont)
      
      end function
      '--------------------------------------------------------------------------
      sub InvertLine( byval hList as dword, 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(hList)
      
          '*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(hList, hDC)
      
      end sub
      
      '--------------------------------------------------------------------------
      ' Load 16 Custom colors up for our ChooseColor() Dialog
      '--------------------------------------------------------------------------
      sub InitializeCustomColors( pColors as dword)
      
        local lCounter as long
        local pl       as long ptr
        'load your custom colors...
        randomize timer
        pl = pColors
        for lCounter = 0 to 15
          'example colors,
          @pl = rnd(0,16777215)
          incr pl
        next
      
      end sub
      '-------------------------------------------------------------------------
      function ListBoxProc(byval hWnd as long, byval wMsg as long, _
                           byval wParam as long, byval lParam as long) as long
          local d, hbrush, hCursorSize, hinst  as dword
          local lBoxSelText     as string
          local sz              as asciz * 64
          local psz             as asciz ptr
          local cursel, hDC, nindex as long
          local r, rc, rc2, rectfull as rect
          local pt              as pointapi
          local p_item, q_item, r_item as PROPERTYITEM ptr
          local pitem           as propertyitem ptr
          local h, i, l, n, idx, tlen      as long
          local pDrawItem            as DRAWITEMSTRUCT ptr
          local pdw             as dword ptr
          local hmem            as dword ' memory handle for GlobalMem operations
          local newStr as asciiz*255
          local lstaticptr as tLBInstance ptr
          static oldproc as dword
          local s as string
      
          ' message from  CreateSuperClass to give us the WNDPROC for the base class
          if hWnd = 0 then
              OldProc = wparam
              'OffsetWndExtra = Lparam
              exit function
          end if
          '
          select case Wmsg
              '
              case %wm_create
                  globalmem alloc sizeof(tLBInstance) to hMem
                  globalmem lock hMem to lstaticptr
                  s  = string$(sizeof(tLBInstance), 0)
                  movememory byval lstaticptr, byval strptr(s), sizeof(tLBInstance) ' zero fill the UDT
                  @lstaticPtr.hMem = hMem
                  @lstaticPtr.bInitialising = 1
                  @lstaticptr.ppty = %NULL
                  setprop (hWnd, "INSTVARS", lstaticPtr)
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  'hCursorArrow =  LoadCursor( %NULL, byval %IDC_ARROW )
                  hinst = getmodulehandle(byval 0)
                  @lstaticptr.bTracking = %FALSE
                  @lstaticptr.nDivider  = 0
                  @lstaticptr.bDivIsSet = %FALSE
                  '  Create the controls that will need to edit the Properties with.
                  '  They are all hidden for now and resized later.
                  @lstaticptr.hButton = CreateWindowEx(0,"BUTTON","", _
                                            %ws_child or %ws_clipsiblings or %bs_pushbutton or %ss_centerimage, _
                                            0,0,8,12, _
                                            hWnd, %PP2_BUTTON, hInst, byval %NULL)
      
                  @lstaticptr.hCombo  = CreateWindowEx(0,"COMBOBOX", "", _
                                            %ws_child or %cbs_dropdownlist or %cbs_nointegralheight, _
                                            0,0,10,100, _
                                            hWnd, %PP2_COMBO, hInst, byval %NULL)
      
                  @lstaticptr.hEdit   = CreateWindowEx(0,"EDIT", "True", _
                                            %ws_child or %ws_clipsiblings or %es_left or %es_autohscroll or %ws_border, _
                                            0,0,10,20, _
                                            hWnd, %PP2_EDIT, hInst, byval %NULL)
      
                  @lstaticptr.hEdNum  = CreateWindowEx(0,"EDIT", "", _
                                            %ws_child or %ws_clipsiblings or %es_left or %es_number or _
                                            %es_autohscroll or %ws_border, _
                                            0,0,10,20, _
                                            hWnd, %PP2_EDNUM, hInst, byval %NULL)
                  call InitializeCustomColors( varptr(@lstaticptr.Ccolor(0)))
                  @lstaticPtr.bInitialising = 0
              '
              case %WM_SETFONT
                  lstaticptr = getprop (hWnd, "INSTVARS")
      '            @lstaticptr.hfont = wparam
                  call SendMessage( @lstaticptr.hEdit, %WM_SETFONT, @lstaticptr.hFont, 0 )
                  call SendMessage( @lstaticptr.hEdNum, %WM_SETFONT, @lstaticptr.hFont, 0 )
                  call SendMessage( @lstaticptr.hCombo, %WM_SETFONT, @lstaticptr.hFont, 0 )
                  ' NB SetFont does not return a value
              '
              case %wm_vscroll
                  ' hide the embedded button, combo, etc control
                  sendmessage hWnd, %wm_user + %our_hide_embedded_control, 0, 0
      
              'Catch the Combo,Edit,Button child control notifications here...
              case %wm_command
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  if @lstaticPtr.bInitialising then exit select
                  cursel = sendmessage ( hWnd, %LB_GETCURSEL,0,0)
                  sendmessage ( hWnd, %LB_GETTEXT, cursel, varptr(sz)) ' get selected text = propertyname
                  lBoxSelText = trim$(sz)
                  pitem = sendmessage ( hWnd, %wm_user + %our_get_property, varptr(sz), 0 ) ' get pointer to item structure
                  '
                  select case lo(word,wparam)
                      '
                      case %PP2_COMBO
                           if (hi(word,wparam) = %cbn_selchange) then
                               local selStr as asciiz*255
                               if @lstaticptr.hCombo <> 0  then
                                  idx& = SendMessage( @lstaticptr.hCombo, %CB_GETCURSEL ,0 ,0 )
                                  call SendMessage( @lstaticptr.hCombo, %CB_GETLBTEXT, idx& , varptr(selStr) )
                                  @pItem.curValue = selStr
                               end if
                           end if
                      '
                      case %PP2_EDIT
                           if (hi(word,wparam) = %en_change) then
                               tLen&  = SendMessage(@lstaticptr.hEdit, %WM_GETTEXTLENGTH, 0, 0) + 1
                               newStr = space$(tLen&)
                               call SendMessage(@lstaticptr.hEdit, %WM_GETTEXT, tLen&, varptr(newStr))
                               if pitem <> 0 then ' no items exist during initialisation!
                                   @pItem.curValue = newStr
                               end if
                           end if
                      '
                      case %PP2_EDNUM
                           if (hi(word,wparam) = %en_change) then
                               tLen& = SendMessage(@lstaticptr.hEdnum, %WM_GETTEXTLENGTH, 0, 0) + 1
                               newStr = space$(tlen&)
                               call SendMessage(@lstaticptr.hEdnum, %WM_GETTEXT, tLen&, varptr(newStr))
                               if pitem <> 0 then ' no items exist during initialisation!
                                   @pItem.curValue = newStr
                               end if
                           end if
                      '
                      case %PP2_BUTTON
                           if (hi(word,wparam) = %bn_clicked) then
                               cursel = sendmessage ( @lstaticptr.hButton, %LB_GETCURSEL,0,0)
                               call OnButtonClicked( hWnd, varptr(@lstaticptr.Ccolor(0)))
                           end if
                  '
                  end select
      
              case %wm_lbuttondown
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  if @lstaticptr.hCombo  <> 0 then call ShowWindow( @lstaticptr.hCombo,  %sw_hide )
                  if @lstaticptr.hEdit   <> 0 then call ShowWindow( @lstaticptr.hEdit,   %sw_hide )
                  if @lstaticptr.hEdNum  <> 0 then call ShowWindow( @lstaticptr.hEdNum,  %sw_hide )
                  if @lstaticptr.hButton <> 0 then call ShowWindow( @lstaticptr.hButton, %sw_hide )
                  '-----------------------[ Splitter ]-----------------------
                  pt.x = lowrd(Lparam)
                  pt.y = hiwrd(Lparam)
      
                  if ((pt.x >= @lstaticptr.nDivider-5) and (pt.x <= @lstaticptr.nDivider+5)) then
                      'if mouse clicked on divider line, then start resizing
                      hCursorSize  =  LoadCursor( %NULL, byval %IDC_SIZEWE )
                      call SetCursor(hCursorSize)
      
                      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 )
                      @lstaticptr.bTracking = %TRUE
      
                      @lstaticptr.nDivTop   = rc.ntop
                      @lstaticptr.nDivBtm   = rc.nbottom
                      @lstaticptr.nOldDivX  = pt.x
      
                      call InvertLine( hWnd, @lstaticptr.nOldDivX ,@lstaticptr.nDivTop ,@lstaticptr.nOldDivX ,@lstaticptr.nDivBtm )
      
                      'capture the mouse
                      call SetCapture(hWnd)
      
                  end if
      
      
              case %wm_mousemove
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  pt.x = lowrd(Lparam)
                  pt.y = hiwrd(Lparam)
      
                  'move divider line to the mouse position
                  'if columns are currently being resized
                  if @lstaticptr.bTracking = %TRUE  then
                      'remove old divider line
                      call InvertLine( hWnd, @lstaticptr.nOldDivX ,@lstaticptr.nDivTop ,@lstaticptr.nOldDivX ,@lstaticptr.nDivBtm )
                      'draw new divider line
                      call InvertLine( hWnd, pt.x ,@lstaticptr.nDivTop ,pt.x ,@lstaticptr.nDivBtm )
                      @lstaticptr.nOldDivX = pt.x
                  else
                      'set the cursor to a sizing cursor if
                      'the cursor is over the row divider
                      if (pt.x >= @lstaticptr.nDivider-5) and (pt.x <= @lstaticptr.nDivider+5) then
                          hCursorSize  =  LoadCursor( %NULL, byval %IDC_SIZEWE )
                         call SetCursor(hCursorSize)
                      end if
                 end if
      
              case %wm_lbuttonup
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  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 @lstaticPtr.bTracking = %TRUE then
      
                      @lstaticPtr.bTracking = %FALSE
                      call ReleaseCapture()
                      call ClipCursor( byval %NULL )
      
                      call InvertLine( hWnd, pt.x ,@lstaticPtr.nDivTop ,pt.x ,@lstaticPtr.nDivBtm )
      
                      'set the divider position to the new value
                      @lstaticPtr.nDivider = pt.x
      
                      'Self paint the ListBox control...
                      call InvalidateRect(hWnd ,byval %NULL, 1)
                      call UpdateWindow(hWnd)
      
                  end if
              '---------------------[ end of splitter ]------------------
              ' user messages
              case %wm_user + %our_setfont ' wparam is an asciz ptr to fontspec string "fontname|pointsize|attributes"
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  @lstaticptr.hfont = PropMakeFont (byval wparam)
                  sendmessage hWnd, %wm_setfont, @lstaticptr.hfont, 0
                  exit function
              '
              case %wm_user + %our_SetBgColor
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  @lstaticptr.BGColor = wparam
                  exit function
              '
              case %wm_user + %our_hide_embedded_control
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  if @lstaticptr.hCombo  <> 0 then call ShowWindow( @lstaticptr.hCombo,  %sw_hide )
                  if @lstaticptr.hEdit   <> 0 then call ShowWindow( @lstaticptr.hEdit,   %sw_hide )
                  if @lstaticptr.hEdNum  <> 0 then call ShowWindow( @lstaticptr.hEdNum,  %sw_hide )
                  if @lstaticptr.hButton <> 0 then call ShowWindow( @lstaticptr.hButton, %sw_hide )
                  exit function
              '
              case %wm_user + %our_lb_selchange ' sent when LB_SELCHANGE rec'd by parent
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  curSel = SendMessage( hWnd, %LB_GETCURSEL, 0, 0 )
                  call OnSelChange(hWnd, @lstaticptr.hcombo, @lstaticptr.hbutton, @lstaticptr.hedit, @lstaticptr.hednum, @lstaticptr.ndivider)
                  exit function
              '
              case %wm_user + %our_DRAWITEM ' parent has rec'd a WM_DRAWITEM msg
                  lstaticptr = getprop (hWnd, "INSTVARS")
      
                  pDrawItem = Lparam
                  if @pDrawItem.itemID < 0 then
                      exit select
                  end if
                  if @lstaticptr.bTracking = %TRUE then exit function
                  rectFull = @pDrawItem.rcItem
                  rc = rectFull
                  if @lstaticptr.nDivider = 0 then @lstaticptr.nDivider   = (rc.nRight - rc.nLeft)  \ 2
                  rc.nleft   = @lstaticptr.nDivider
                  rc2        = rectFull
                  rc2.nright = rc.nleft - 1
                  @lstaticptr.nIndex     = @pDrawItem.itemID
                  sendmessage ( hWnd, %LB_GETTEXT, @lstaticptr.nIndex, varptr(sz)) ' get selected text = propertyname
                  lBoxSelText = trim$(sz)
                  pitem = sendmessage ( hWnd, %wm_user + %our_get_property, varptr(sz), 0 ) ' get pointer to item structure
                  if  nIndex  > -1  then
                      'draw two rectangles, one for each row column
                      hBrush = CreateSolidBrush( @lstaticptr.bgcolor)
                      call FillRect(@pDrawItem.hDC , rc2, hBrush )
                      call DeleteObject(hBrush)
      
                      call DrawEdge(@pDrawItem.hDC , rc2, %EDGE_SUNKEN,%BF_BOTTOMRIGHT )
                      call DrawEdge(@pDrawItem.hDC , rc,  %EDGE_SUNKEN,%BF_BOTTOM )
      
                      call SetBkMode( @pDrawItem.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
                      if @pitem.subtype  then
                          l = %DT_RIGHT
                      else
                          l = %DT_LEFT
                      end if
                      call DrawText( @pDrawItem.hDC , @pItem.propName, _
                         len(@pItem.propName), _
                         rc2, l 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(@pDrawItem.hDC , @pItem.curValue, _
                                    len(@pItem.curValue), _
                                    rc, %dt_left or %DT_SINGLELINE )
                      '
                      if (@pitem.subtype = %PITS_FONTCOLOR) or (@pitem.nItemtype = %PIT_COLOR) then
                           n = Str2RGB(trim$(@pitem.CurValue))
                           hBrush = CreateSolidBrush( n)
                           rc.nleft   = rc.nright   - 20
                           rc.ntop    = rc.ntop     - 1
                           rc.nright  = rc.nright   - 5
                           rc.nbottom = rc.nbottom  - 8
                           call FillRect(@pDrawItem.hDC , rc, hBrush )
                           call DrawEdge(@pDrawItem.hDC , rc,  %EDGE_SUNKEN,%BF_SOFT )
                           call DeleteObject(hBrush)
                       end if
                  end if
      
                  '<insert here>  Add some kind of item focus rect
                  exit function
      
              case %wm_user + %our_add_property
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  ' grab memory to hold new property and initialise to zeros
                  h = GlobalAlloc ( %GPTR, sizeof(PropertyItem))
                  ' move property details into memory
                  movememory ( byval h, byval lparam, sizeof(PROPERTYITEM))
                  ' add it into list at end
                  if @lstaticptr.ppty = %NULL then ' the list is empty
                      @lstaticptr.ppty = h
                  else
                      p_item = @lstaticptr.ppty
                      while @p_item.fptr <> %NULL
                          p_item = @p_item.fptr
                      wend
                      @p_item.fptr = h
                  end if
                  q_item = h
                  sz = @q_item.propname
                  call SendMessage(hWnd,%LB_ADDSTRING,0,varptr(sz))
                  function = 1
                  exit function
              '
              case %wm_user + %our_get_property
                  ' wparam has a ptr to propertyname
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  ' find property by name
                  p_item = @lstaticptr.ppty
                  if p_item = 0 then exit function ' empty list
                  psz = Wparam
                  while trim$(@p_item.propname)  <> trim$(@psz)
                      if @p_item.fptr = 0 then
                          function = 0
                          exit function ' return null pointer
                      end if
                      p_item = @p_item.fptr
                  wend
      
                  ' return msg with pointer to it
                  function = p_item ' return pointer to property
                  exit function
                  'sendmessage ( hParent, %WM_USER + %our_ispty, 0, p_item)
              '
              case %wm_user + %our_get_property_count
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  ' count properties in list
                  p_item = @lstaticptr.ppty
                  if p_item = %NULL then exit function ' return zero
                  while %TRUE
                      incr i
                      p_item = @p_item.fptr
                      if p_item = %NULL then
                          @lstaticptr.nproperties = i
                          function = i
                          exit function
                      end if
                  wend
                  exit function ' we never get here!
              '
              case %wm_destroy
                  lstaticptr = getprop (hWnd, "INSTVARS")
                  removeprop (hWnd, "INSTVARS")
                  ' deallocate memory in property linked list
                  p_item = @lstaticptr.ppty
                  while p_item <> %null
                      q_item = p_item
                      p_item = @p_item.fptr
                      globalfree( byval q_item )
                  wend
                  deleteobject @lstaticptr.hfont
                  hMem = @lstaticPtr.hMem
                  globalmem unlock hMem to l
                  globalmem free hmem to hMem
                  if l then ? "error freeing memory"
                  '
                  call PostQuitMessage( 0 )
          end select
      
          ' if the message was received as a user message, it is not processed further
          if (Wmsg > %wm_user) and ( Wmsg < %wm_user + %our_msg_max) then exit function
          function = CallWindowProc(OldProc, hWnd, Wmsg, Wparam, Lparam)
      end function
      '

      Comment


      • #4
        Thanks!
        Andrea Mariani
        AS/400 expert
        Basic programmer @ Home

        Comment

        Working...
        X