Ownerdrawn Listbox for PB 10

[Theo Gottwald]

Code Select Expand

'  OwnerDrawn ListBox.bas
'  with draggable split screen
' https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/23505-custom-control-properties-listbox?p=431385#post431385
      ' made it compilable to PBWIN 10 and somewhat colorful

'--------------------------------------------------------------------------------------------
' Module:  ListProp.Bas
' Desc:    OwnerDraw ListBox
' Purpose: For exploring "User Desinged" custom control properties <adding later>
' Date:    Jan. 23, 2001
' Name:    By Jules Marchildon  <jmarchildon@look.ca>
'--------------------------------------------------------------------------------------------

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

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

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

GLOBAL lpOldListProc  AS LONG

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

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


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

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

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

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

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

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

    szpgmname = "PROPLIST"

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

    result = RegisterClassEx (wndclss)

    IF result = 0 THEN
        result = getlasterror
        ERR = result
        ?ERROR$
    END IF

    ghInst = hInstance

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

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

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

END FUNCTION


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

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

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


    ghMain = hWnd

'---
SELECT CASE wMsg
    CASE %WM_CREATE

            DIM pItem(0 TO 16) AS PROPERTYITEM

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

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

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

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

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

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

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

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

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

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

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

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

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

            '  Add our User designed Custom Control
            CALL InitializeUserCustomControl()

            FUNCTION = %TRUE
            EXIT FUNCTION


    CASE %WM_PAINT
        ' dialog paint
       DrawGradientDlg(ghMain, %RGB_LIGHTYELLOW, %RGB_AZURE)



    CASE %WM_MEASUREITEM

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

         FUNCTION = %TRUE
         EXIT FUNCTION


    CASE %WM_DRAWITEM

        lpDs = lParam

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

        IF bTracking = %TRUE THEN EXIT FUNCTION

        rectFull = @lpDs.rcItem
        rc = rectFull

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

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

        IF  nIndex  > -1  THEN

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

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

            CALL SetBkMode( @lpDs.hDC , %TRANSPARENT )

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

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

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

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

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

        FUNCTION = %TRUE
        EXIT FUNCTION


    CASE %WM_COMMAND

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

        '---
        CASE %WM_DESTROY

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

    END SELECT

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


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

    LOCAL rc AS RECT
    LOCAL lBoxSelText AS STRING

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

    rc.nleft = nDivider

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

    IF pItem(curSel).nItemType = %PIT_COMBO  THEN

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

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

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

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

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

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

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

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

    ELSEIF pItem(curSel).nItemType = %PIT_EDIT  THEN

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

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

        lBoxSelText = pItem(curSel).curValue

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

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

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

        nWidth& = rc.nright - rc.nleft

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

        rc.nbottom = rc.nbottom - 3

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

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

    END IF

END SUB


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

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


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

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

        currClr = pItem(curSel).curValue

        IF  currClr > "" THEN

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

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

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

        lResult = ChooseColor(ColorSpec)

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

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

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

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

            'Call ShowWindow( ghButton,%SW_HIDE )

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

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

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

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

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

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

'    END IF '<remove later>

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

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

        lResult = ChooseFont(cf)

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

            'Call ShowWindow( ghButton,%SW_HIDE )

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

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

        END IF

    END IF

END SUB


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

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

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

END FUNCTION


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

    LOCAL pt AS POINTAPI


    SELECT CASE wMsg

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

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

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



        END SELECT




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

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

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

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

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

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

                CALL InvertLine( nOldDivX ,nDivTop ,nOldDivX ,nDivBtm )

                'capture the mouse
                CALL SetCapture(hWnd)

            END IF


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

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

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

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

                nOldDivX = pt.x

            ELSE

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

           END IF


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

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

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

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


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

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

            END IF

           CASE %WM_CAPTURECHANGED
                IF lParam <> ghList THEN
                    IF bTracking = %TRUE THEN
                        bTracking = %FALSE
                        CALL ReleaseCapture()
                        CALL ClipCursor( BYVAL %NULL )
                        CALL InvalidateRect(ghList ,BYVAL %NULL, 1)
                        CALL UpdateWindow(ghList)
                    END IF
                END IF


           '---------------------[ end of splitter ]------------------

    END SELECT

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

END FUNCTION


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


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

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

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

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

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

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

END SUB

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

END SUB


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

  LOCAL lCounter AS LONG

  DIM cColor(0 TO 15)

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

END SUB


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

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


END SUB


' Great Thanks to Borje
' GradientFill routine for dialog
' Modified to mix both horizontal and vertical gradient fills
'--------------------------------------------------------------------
SUB DrawGradientDlg(hWnd AS DWORD, rgbColA AS DWORD, rgbColB AS DWORD)
  LOCAL grc       AS RECT
  LOCAL gps       AS PAINTSTRUCT
  LOCAL gRect    AS  GRADIENT_RECT
  DIM   vert(1)  AS  LOCAL TRIVERTEX

  IF BeginPaint(hWnd, gps) THEN
      GetClientRect hWnd, grc

      vert(0).x      = 0
      vert(0).y      = 0
      vert(0).Red    = VAL("&H" + HEX$(GetRValue(rgbColA)) + "00")  ' red component
      vert(0).Green  = VAL("&H" + HEX$(GetGValue(rgbColA)) + "00")  ' green component
      vert(0).Blue   = VAL("&H" + HEX$(GetBValue(rgbColA)) + "00")  ' blue component
      vert(0).Alpha  = &H0000
      vert(1).x      = grc.nRight
      vert(1).y      = grc.nBottom
      vert(1).Red    = VAL("&H" + HEX$(GetRValue(rgbColB)) + "00")  ' red component
      vert(1).Green  = VAL("&H" + HEX$(GetGValue(rgbColB)) + "00")  ' green component
      vert(1).Blue   = VAL("&H" + HEX$(GetBValue(rgbColB)) + "00")  ' blue component
      vert(1).Alpha  = &H0000

      gRect.UpperLeft  = 0
      gRect.LowerRight = 1

     ' modified to have both vertical and horizontal gradient fill
     ' for horizontal gradient fill
      GradientFill gps.hDC, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_V
       ' %GRADIENT_FILL_RECT_H for vertical gradient _H
      GradientFill gps.hDC, vert(0), 2, gRect, 1, %GRADIENT_FILL_RECT_H
      EndPaint hWnd, gps
  END IF

END SUB

Source: [url=https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/23505-custom-control-properties-listbox]Powerbasic Forum[/url]