' 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]