Announcement

**Chris Holbrook** · 7 Feb 2008, 02:19 PM

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

[/code]

**Chris Holbrook** · 11 Dec 2009, 03:38 PM

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
'

**Andrea Mariani** · 11 Dec 2009, 06:04 PM

Thanks!

Announcement

Forum Guidelines

Properties List control

Properties List control

Comment

Comment

Comment