This is incomplete but there has been some interest in progress so I'm posting it warts and all.
In particular, the snap to grid processing has been revised, and the control right-click menu includes a Properties option, which enables font selection and styles selection to be done. Comments in the Windows forum, please.
** update 23-Dec-2007 **
Now generates PB DDT code. You will need both the compiled program and the STYLES.TXT file (below)
** update 27-Dec-2007
bug fixes in snap/size to grid and loading from .ftf file
In particular, the snap to grid processing has been revised, and the control right-click menu includes a Properties option, which enables font selection and styles selection to be done. Comments in the Windows forum, please.
** update 23-Dec-2007 **
Now generates PB DDT code. You will need both the compiled program and the STYLES.TXT file (below)
** update 27-Dec-2007
bug fixes in snap/size to grid and loading from .ftf file
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Visual designer originally based upon Borje Hagsten's DrawRect sample
' of March 2003.
' Provides a floating menu and moveable "controls", being dialogs
' each with a single control to represent the eventual type style
' and placement of the control in the generated program.
' Generates ONE dialog with < 1000 controls.
' Control types are restricted to LABEL, TEXTBOX, CHECKBOX, LISTBOX, LISTVIEW, BUTTON.
'
' CJH 6-DEC-2007
'--------------------------------------------------------------------
' Change History
' 6-Dec-2007 GUI design PoC accepted
' 17-Dec-2007 added properties, snap to grid revised
' 22-Dec-2007 save to file, export PB DDT source
'--------------------------------------------------------------------
' Issues
' 1. No grab handles on controls. Not sure if this matters.
' 2. Help on styles is supposed to be by using a multiline tooltip - not done yet
' 3. Size to grid not working when a control is resized
' 4. No control group formatting functions eg L/R align block of controls, etc
' 5. Selected styles still not applied to controls in the designer
'
#COMPILE EXE
#DIM ALL
#INCLUDE "commctrl.inc"
#INCLUDE "WIN32API.INC"
#INCLUDE "comdlg32.inc"
'--------------------------------------------------------------------
' debug macro for use with dbgview.exe
%enable_debug = %TRUE
MACRO DP(st)
#IF %ENABLE_DEBUG
CALL OutputDebugString(st)
#ENDIF
END MACRO
'--------------------------------------------------------------------
' timer related
%TIMER_SNAP = 99 ' timer for snapping CCs to grid
%TIMER_REDRAW_GRID = 98 ' timer for redrawing grid
%TIMEOUT_SNAP = 200 ' timer delay for snap to grid
%TIMEOUT_REDRAW_GRID = 500 ' timer delay for redrawing grid
'--------------------------------------------------------------------
%IDC_CHK1 = 121
%IDC_CHK2 = 122
%IDC_CHK3 = 128
%IDC_CHK4 = 129
%IDC_LAB1 = 123
%IDC_LAB2 = 124
%IDC_GRIDX_TB = 125
%IDC_GRIDY_TB = 126
%IDC_SHOWCONTROLS_LV = 127
'--------------------------------------------------------------------
' popup CC menu ids
%IDM_POPUP1 = 150
%IDM_POPUP2 = 151
%IDM_POPUP3 = 152
'--------------------------------------------------------------------
%our_typecontrol_base = 500
%our_dialog_type = 0
%our_label_type = 1
%our_textbox_type = 2
%our_checkbox_type = 3
%our_listbox_type = 4
%our_listview_type = 5
%our_button_type = 6
'
%IDC_GRIP = 700
' keep type identifier control declarations in a contiguous block
%IDC_CTL1 = %our_typecontrol_base + %our_label_type
%IDC_CTL2 = %our_typecontrol_base + %our_textbox_type
%IDC_CTL3 = %our_typecontrol_base + %our_checkbox_type
%IDC_CTL4 = %our_typecontrol_base + %our_listbox_type
%IDC_CTL5 = %our_typecontrol_base + %our_listview_type
%IDC_CTL6 = %our_typecontrol_base + %our_button_type
' -------------------------------------------------------------------
' PROPERTIES EQUATES
%IDD_CP = 101
%IDC_TEXTBOX1 = 1001
%IDC_LABEL1 = 1064
%IDC_LABEL4 = 1067
%IDC_CTRL_TYPE_LAB = 1066
%IDC_CTRL_NO_LAB = 1065
%IDC_TEXT_TB = 1034
%IDC_LABEL2 = 1084
%IDC_STYLES_TB = 1035
%IDC_AV_STYLES_LV = 1036
%IDC_LABEL3 = 1085
%IDC_LABEL21 = 1086
%IDC_LABEL22 = 1087
%IDC_FONT_BN = 1037
%IDC_FONTSIZE_LAB = 1088
%IDC_FONTATTS_LAB = 1089
%IDC_LINE1 = 1092
%IDC_LINE2 = 1093
%IDC_W_LAB = 1097
%IDC_H_LAB = 1098
%IDC_Y_LAB = 1095
%IDC_X_LAB = 1094
%IDC_SAVE_BN = 1095
%IDC_DEF_STYLES_BN = 1101
%IDC_BGCOLOR_BN = 1102
%IDC_ORG_STYLES_BN = 1103
'--------------------------------------------------
' Styles listview stuff
%IDC_LV = 1500
%IDC_TB = 1501
%IDC_LV2TB = 1502
%IDC_TB2LV = 1503
%idc_CCID = 550
%GRIDSIZEX = 10
%GRIDSIZEY = 10
' project control stuff
$STYLESDBPATH = "STYLES.TXT"
$PBWINCMD = "C:\PBWIN80\bin\PBWIN"
$PBWININCLUDES = " /IC:\PBWIN80\WINAPI"
$ROOTDIR = "C:\chris\mcodegen"
'------------------------------------------
' styles stuff for generated controls
$DEFAULT_LAB_STYLES = "WS_CHILD,WS_VISIBLE,SS_LEFT,WS_EX_LEFT,WS_EX_LTRREADING"
$DEFAULT_TB_STYLES = "WS_CHILD,WS_VISIBLE,WS_TABSTOP,ES_LEFT,ES_AUTOHSCROLL," _
+ "WS_EX_CLIENTEDGE,WS_EX_LEFT,WS_EX_LTRREADING,WS_EX_RIGHTSCROLLBAR"
$DEFAULT_CB_STYLES = "WS_CHILD,WS_VISIBLE,BS_AUTO_CHECKBOX,BS_LEFT,BS_VCENTER,WS_EX_LEFT,WS_EX_LTRREADING"
$DEFAULT_LB_STYLES = "WS_CHILD,WS_TABSTOP,WS_VISIBLE,WS_VSCROLL,LBS_NOTIFY,WS_EX_CLIENTEDGE,WS_EX_LEFT,WS_EX_LTRREADING,WS_EX_RIGHTSCROLLBAR"
$DEFAULT_BN_STYLES = "WS_CHILD,WS_TABSTOP,WS_VISIBLE,BS_TEXT,BS_PUSHBUTTON,BS_CENTER,BS_VCENTER,WS_EX_LEFT,WS_EX_LTRREADING"
$DEFAULT_LV_STYLES = "WS_CHILD,WS_TABSTOP,WS_VISIBLE,LVS_SHOWSELALWAYS,LVS_REPORT," _
+ "WS_EX_CLIENTEDGE,LVS_EX_LABELTIP,LVS_EX_INFOTIP,WS_EX_LEFT,WS_EX_RIGHTSCROLLBAR"
$DEFAULT_DLG_STYLES = "WS_SYSMENU,WS_VISIBLE,WS_CLIPCHILDREN,DS_NOFAILCREATE,DS_3DLOOK,DS_SETFONT,WS_EX_RIGHTSCROLLBAR"
'-----------------------------------------
' styles stuff for this program's controls
%DEFAULT_LV_STYLES = %ws_child OR %WS_TABSTOP OR %WS_VISIBLE OR %LVS_SHOWSELALWAYS OR %LVS_REPORT
%DEFAULT_LV_EX_STYLES = %WS_EX_CLIENTEDGE OR %LVS_EX_LABELTIP OR %LVS_EX_INFOTIP OR %WS_EX_LEFT OR %WS_EX_RIGHTSCROLLBAR
'--------------------------------------------------------------------
' numeric decode of control types
'--------------------------------------------------------------------
DECLARE CALLBACK FUNCTION DlgProc() AS LONG
DECLARE FUNCTION MakeGridBrush (BYVAL hDlg AS DWORD) AS DWORD
DECLARE SUB selRectBegin (BYVAL hWnd AS DWORD)
DECLARE SUB selRectDraw (BYVAL hWnd AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG, RC AS RECT)
DECLARE FUNCTION selRectEnd (BYVAL hWnd AS DWORD, RCT AS RECT) AS LONG
DECLARE FUNCTION FloatMenu_dialog(BYVAL hParent AS DWORD) AS LONG
DECLARE FUNCTION ShowCControls ( BYVAL hParent AS DWORD) AS LONG
DECLARE FUNCTION ShowPROP(BYVAL hParent AS DWORD) AS LONG
DECLARE SUB ExportPBSource(hD AS DWORD)
DECLARE SUB LoadCCS(hD AS DWORD)
DECLARE SUB SaveCCS(hD AS DWORD, sfile AS STRING)
DECLARE SUB Snap2Grid ( hW AS DWORD )
'--------------------------------------------------------------------
TYPE CPH ' control place holder
hD AS DWORD ' dialog handle
cid AS LONG ' control identifier used in generated code
lCtrlType AS LONG ' numeric index to type being control id of type - %IDC_CTL1, q.v.
sText AS STRING * 256 ' text for this control
sStyles AS STRING * 400 ' list of styles for this control
lFontSize AS LONG
sFont AS STRING * 40 '
sFontAtts AS STRING * 80 ' combination of Bold, Italic, Underline, Strikethrough etc
lFGColour AS LONG ' raw FG colour value
lBGColour AS LONG ' raw BG Color value
X AS LONG
Y AS LONG
W AS LONG
H AS LONG
sImgPath AS STRING * 256 ' path to image, static controls only
hFont AS LONG
lGridX AS LONG ' grid settings for reload - valid in row 0 only
lGridY AS LONG ' grid settings for reload - valid in row 0 only
ncontrols AS LONG ' highest index in use - valid in row 0 only
hcurs AS LONG ' cursor for ccontrol not for gen'd app
END TYPE
'--------------------------------------------------------------------
GLOBAL gGridSizeX AS LONG
GLOBAL gGridSizeY AS LONG
GLOBAL gShowGrid AS LONG
GLOBAL gSnapToGrid AS LONG
GLOBAL gSize2Grid AS LONG
GLOBAL ghBit AS DWORD
GLOBAL ghBrush AS DWORD
GLOBAL gMemDC AS DWORD
GLOBAL gPt AS POINTAPI
GLOBAL gRc AS RECT
GLOBAL gCCX AS LONG ' highest index to gCcontrol in use
GLOBAL gCcontrols() AS CPH
GLOBAL ghMenuDialog AS DWORD ' handle for floating menu dialog
GLOBAL ghCCDialog AS DWORD ' handle for current CCdialog
GLOBAL ghSCDialog AS DWORD ' handle for CControls table dialog
GLOBAL ghMAINDD AS DWORD ' handle for main dialog on which CCs are drawn
GLOBAL ghPROPDD AS DWORD ' handle for Properties dialog
GLOBAL gSControlTypes AS STRING
GLOBAL gsDialogStyles AS STRING ' global default styles for main dialog
GLOBAL glDIALOGPROPERTIES AS LONG ' %TRUE if editing DIALOG properties, else editing CONTROL properties
GLOBAL G_APP_NAME AS STRING' generated application filename
'-------------------------------------------------------------------
' common functions
'--------------------------------------------------------------------
FUNCTION ChooseFontDlgHookProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, BYVAL lParam AS LONG ) AS LONG
LOCAL X AS LONG, Y AS LONG, R AS RECT
SELECT CASE wMsg
CASE %WM_INITDIALOG
'CENTER DIALOG IN PARENT
GetWindowRect GetParent(hWnd), R 'get parent's data
X = R.nLeft + ((R.nRight - R.nLeft) \ 2) 'calculate parent's width
Y = R.nTop + ((R.nBottom - R.nTop) \ 2) 'calculate parent's height
GetWindowRect hWnd, R 'get dialog's width and height
R.nLeft = X - (( R.nRight - R.nLeft ) \ 2)
R.nTop = Y - (( R.nBottom - R.nTop ) \ 2)
SetWindowPos hWnd, %NULL, R.nLeft, R.nTop, 0, 0, %SWP_NOSIZE OR %SWP_NOZORDER 'set centered pos
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
' Choose Font for a control...
'------------------------------------------------------------------------------
FUNCTION ChooseQTPFont(BYVAL hDlg AS LONG) AS DWORD
STATIC cf AS CHOOSEFONTAPI
STATIC lf AS LOGFONT
cf.lStructSize = SIZEOF(cf)
cf.lpLogFont = VARPTR(lf)
cf.hWndOwner = hDlg
cf.Flags = %CF_SCREENFONTS OR _
%CF_EFFECTS OR _
%CF_ENABLEHOOK OR _
%CF_INITTOLOGFONTSTRUCT
cf.rgbColors = getsyscolor (%COLOR_WINDOWTEXT)
cf.lpfnHook = CODEPTR(ChooseFontDlgHookProc)
IF ChooseFont(cf) THEN
FUNCTION = VARPTR(cf)
END IF
END FUNCTION
'--------------------------------------------------------------------
SUB DummyListBox( hD AS DWORD, hC AS LONG, n AS LONG)
LOCAL i AS LONG
FOR i = 1 TO n
LISTBOX ADD hD, hC, USING$("Example Item #", i)
NEXT
END SUB
'---------------------------------------------------------------------
SUB SampleListView(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL lColCnt AS LONG, BYVAL lRowCnt AS LONG)
LOCAL lCol AS LONG
LOCAL lRow AS LONG
LOCAL hCtl AS DWORD
LOCAL tLVC AS LV_COLUMN
LOCAL tLVI AS LV_ITEM
LOCAL szBuf AS ASCIIZ * 32
LOCAL lStyle AS LONG
CONTROL HANDLE hDlg, lID TO hCtl
lStyle = ListView_GetExtendedListViewStyle(hCtl)
ListView_SetExtendedListViewStyle hCtl, lStyle OR %LVS_EX_FULLROWSELECT OR %LVS_EX_GRIDLINES
' Load column headers.
tLVC.mask = %LVCF_FMT OR %LVCF_TEXT OR %LVCF_SUBITEM
tLVC.fmt = %LVCFMT_LEFT
tLVC.pszText = VARPTR(szBuf)
FOR lCol = 0 TO lColCnt - 1
szBuf = USING$("Column #", lCol)
tLVC.iOrder = lCol
ListView_InsertColumn hCtl, lCol, tLVC
NEXT lCol
' Load sample data.
FOR lRow = 0 TO lRowCnt - 1
tLVI.stateMask = %LVIS_FOCUSED
tLVI.pszText = VARPTR(szBuf)
tLVI.iItem = lRow
FOR lCol = 0 TO lColCnt - 1
szBuf = USING$("Column # Row #", lCol, lRow)
tLVI.iSubItem = lCol
tLVI.lParam = lRow
IF lCol = 0 THEN
tLVI.mask = %LVIF_TEXT OR %LVIF_PARAM OR %LVIF_STATE
ListView_InsertItem hCtl, tLVI
ELSE
tLVI.mask = %LVIF_TEXT
ListView_SetItem hCtl, tLVI
END IF
NEXT lCol
NEXT lRow
' Auto size columns.
FOR lCol = 0 TO lColCnt - 2
ListView_SetColumnWidth hCtl, lCol, %LVSCW_AUTOSIZE
NEXT lCol
ListView_SetColumnWidth hCtl, lColCnt - 1, %LVSCW_AUTOSIZE_USEHEADER
END SUB
'----------------------------------------------------------------------
' return the index to the gCcontrols table which has .hD = window handle supplied
FUNCTION CCIndexFromhW ( hW AS DWORD ) AS LONG
LOCAL l AS LONG
FOR l = 1 TO gCCX
IF gCcontrols(l).hD = hW THEN
FUNCTION = l
EXIT FUNCTION
END IF
NEXT
END FUNCTION
'----------------------------------------------------------------------
SUB RemoveCCFRomTable ( hW AS DWORD )
LOCAL l AS LONG
l = CCIndexFromhW(hW)
gCcontrols(l).hD = 0
END SUB
'----------------------------------------------------------------------
'
SUB DrawRectAroundControl(BYVAL hDlg AS DWORD, BYVAL hWnd AS DWORD, BYVAL PenColor AS DWORD)
LOCAL hDC AS DWORD
LOCAL hBrush AS DWORD
LOCAL hPen AS DWORD
LOCAL rc AS RECT
GetWindowRect hWnd, rc 'Get control's pos and size on screen
MapWindowPoints 0, hDlg, rc, 2 'Map rect to dialog
InflateRect rc, -1, -1 'Increase slightly to draw around control
hDC = GetDc(hDlg) 'Use dialog's DC since we want to paint on dialog
hPen = CreatePen(%PS_SOLID OR %PS_INSIDEFRAME, 1, PenColor) 'Create a pen for given color
hPen = SelectObject(hDC, hPen) 'Select the new pen into the DC
hBrush = SelectObject(hDC, GetStockObject(%NULL_BRUSH)) 'Use stock null brush for hollow rect
Rectangle hDC, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom 'Draw the rectangle
SelectObject hDC, hBrush 'Return original pen and brush, then release DC
DeleteObject SelectObject(hDC, hPen)
ReleaseDc hDlg, hDC
END SUB
'----------------------------------------------------------------------
' add a new child dialog with a control of the specififed type & coords to ghMainDialog
SUB AddCcontrol ( ControlType AS LONG, x AS LONG, y AS LONG, w AS LONG, h AS LONG )
LOCAL s AS STRING
LOCAL lcx AS LONG
LOCAL sTXT AS STRING
LOCAL hD AS DWORD
GLOBAL gCcontrols() AS CPH
DIALOG NEW ghMainDD, "", X, Y, W, H, _
%WS_POPUP OR %WS_THICKFRAME OR %WS_CHILD OR _
%WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_TOOLWINDOW OR _
%WS_EX_TOPMOST OR %WS_EX_LEFT OR %WS_EX_LTRREADING TO hD
'
INCR gCCX
' on error resume next
' REDIM PRESERVE gCcontrols(gCCX) AS GLOBAL CPH
' IF ERR <> 0 THEN ? "REDIM FAILED: " + ERROR$
SELECT CASE ControlType
CASE %our_button_type
sTxt = "BN:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_BN_STYLES
CONTROL ADD BUTTON, hD, %IDC_CCID, "", 0,0,0,0,%BS_FLAT
CASE %our_checkbox_type
sTxt = "CB:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_CB_STYLES
CONTROL ADD CHECKBOX, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_label_type
sTxt = "Ll:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_LAB_STYLES
CONTROL ADD LABEL, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_textbox_type
sTxt = "TB:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_TB_STYLES
CONTROL ADD TEXTBOX, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_listbox_type
sTxt = "LB:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_LB_STYLES
CONTROL ADD LISTBOX, hD, %IDC_CCID, , 0,0,0,0
DummyListBox ( hD, %IDC_CCID, 10)
CASE %our_listview_type
'sTxt = "LV:" & FORMAT$(gCCX)
gCcontrols(gCCX).sStyles = $DEFAULT_LV_STYLES
CONTROL ADD "SysListView32", hD, %IDC_CCID, "", 0,0,0,0, %DEFAULT_LV_STYLES, %DEFAULT_LV_EX_STYLES
SampleListView ( hD, %IDC_CCID, 10, 10)
END SELECT
gCcontrols(gCCX).hD = hD
gCcontrols(gCCX).lCtrlType = ControlType 'lCtrlType - %our_typecontrol_base
gCcontrols(gCCX).cid = gCCX
gCcontrols(gCCX).lFGColour = getsyscolor(%COLOR_WINDOWTEXT)
gCcontrols(gCCX).lBGColour = getsyscolor(%COLOR_3DFACE)
gCcontrols(gCCX).sText = TRIM$(sTxt)
gCcontrols(gCCX).sFont = ""
gCcontrols(gCCX).hFont = 0
gCcontrols(gCCX).sFontAtts = ""
gCcontrols(gCCX).X = X
gCcontrols(gCCX).Y = Y
gCcontrols(gCCX).W = W
gCcontrols(gCCX).H = H
CONTROL SET TEXT hD, %IDC_CCID, TRIM$(sTxt)
CONTROL SET LOC hD, %IDC_CCID, 0, 0
DIALOG SHOW MODELESS hD, CALL CC_dialogProc 'TO lRslt
END SUB
'------------------------------------------------------------------------------
' returns %TRUE if control exists else %FALSE
FUNCTION ControlExistsAt ( x AS LONG, y AS LONG ) AS LONG
LOCAL i AS LONG
FUNCTION = %FALSE
FOR i = 1 TO UBOUND(gCcontrols)
IF (gCControls(i).X = X) AND (gCcontrols(i).Y = Y) THEN
FUNCTION = %true
EXIT FUNCTION
END IF
NEXT
END FUNCTION
'------------------------------------------------------------------------------
' Copy a control and show it.
' %1 = handle for underlying dialog, %2 = handle for CControl dialog to copy
FUNCTION CopyControl ( hD AS WORD, hCC AS DWORD ) AS LONG
LOCAL l, lrslt, n, x, y AS LONG
' LOCAL CC AS CPH ' to hold a copy of the copied ccontrol's properties
l = CCIndexFromhW ( hCC )
IF l = 0 THEN EXIT FUNCTION
' each copy is offset by gridsize from the last, so keep bumping loc by gridsize
' until no existing control is thus located, then add to gCcontrols table
X = gCControls(l).X + gGridSizeX
Y = gCControls(l).Y + gGridSizeY
WHILE ControlExistsAt(x, y)
X = X + gGridSizeX
Y = Y + gGridSizeY
WEND
' add a new control of the same type
n = gCControls(l).lCtrlType
AddCcontrol (gCControls(l).lCtrlType, X, Y, gCControls(l).W, gCControls(l).H )
FUNCTION = lrslt
END FUNCTION
'--------------------------------------------------------------------
' snap upper left corner to grid. Leave height & width unchanged
' parameter is dialog handle of Ccontrol
SUB Snap2Grid ( hW AS DWORD )
LOCAL l, X, Y, H, W AS LONG
l = CCIndexFromhW(hW)
IF l = 0 THEN EXIT SUB ' goodness knows how we got here!
DIALOG GET LOC hW TO X, Y
DIALOG GET SIZE hW TO W, H
IF gSnaptoGrid THEN
X = (X \ gGridSizeX) * gGridSizeX ' if snap to grid, calculate "grid'd pos"
Y = (Y \ gGridSizeY) * gGridSizeY ' via multiply of integer divide result
' update controls table
gCcontrols(l).X = X
gCcontrols(l).Y = Y
END IF
IF gSize2Grid THEN
W = ( W \ gGridSizeX) * gGridSizeX ' if snap to grid, calculate "grid'd pos"
H = ( H \ gGridSizeY) * gGridSizeY ' via multiply of integer divide result
IF W = 0 THEN W = gGridSizeX
IF H = 0 THEN H = gGridSizeY
gCcontrols(l).W = W
gCcontrols(l).H = H
END IF
DIALOG SET SIZE hW, W, H
DIALOG SET LOC hw, X, Y
DIALOG REDRAW hW
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Main entrance
'--------------------------------------------------------------------
FUNCTION PBMAIN () AS LONG
LOCAL hDlg AS DWORD, lRes AS LONG
DIM gCcontrols(200) AS GLOBAL CPH
REDIM gSControlTypes(6) AS GLOBAL STRING
gCcontrols(0).lGridX = %GRIDSIZEX
gCcontrols(0).lGridY = %GRIDSIZEY
gsControlTypes(%our_button_type) = "Button"
gsControlTypes(%our_checkbox_type) = "CheckBox"
gsControlTypes(%our_label_type) = "Label"
gsControlTypes(%our_textbox_type) = "TextBox"
gsControlTypes(%our_listbox_type) = "ListBox"
gsControlTypes(%our_listview_type) = $DQ+ "SysListView32" + $DQ
InitCommonControls
DIALOG NEW 0, "One day...",,, 600, 400, _
%WS_CAPTION OR %WS_CLIPCHILDREN OR %WS_SYSMENU OR %WS_THICKFRAME, 0 TO ghMainDD
SetTimer ghMAINDD, %TIMER_SNAP, %TIMEOUT_SNAP, %NULL
SetTimer ghMAINDD, %TIMER_REDRAW_GRID, %TIMEOUT_REDRAW_GRID, %NULL
DIALOG SHOW MODAL ghMAINDD CALL MAINDlgProc
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Main callback
'--------------------------------------------------------------------
CALLBACK FUNCTION MAINDlgProc() AS LONG
LOCAL l, X, Y , W, H AS LONG
STATIC RC AS RECT
STATIC hPopup, menuchoice AS LONG
LOCAL p AS PointAPI
LOCAL s, s1 AS STRING
SELECT CASE CBMSG
CASE %WM_INITDIALOG
'DIM GCCONTROLS(1) AS GLOBAL cph
STATIC hCur AS DWORD ' for static grid brush handle
gGridSizeX = %GRIDSIZEX ' horizontal grid size
gGridSizeY = %GRIDSIZEY ' vertical grid size
gShowGrid = 1 ' show grid at start
gSnapToGrid = 1 ' snap drawing to grid at start
hCur = LoadCursor(0, BYVAL %IDC_CROSS) ' store handle of cursot to use at draw
ghBrush = MakeGridBrush (CBHNDL) ' and create grid brush
l = FloatMenu_Dialog(CBHNDL)
' add dialog properties to gCcontrols table first entry
gCcontrols(0).hd = CBHNDL
gCcontrols(0).cid = 0
gCcontrols(0).lCtrlType = %our_dialog_type
DIALOG GET TEXT CBHNDL TO s
gCcontrols(0).sText = s
gCcontrols(0).sStyles = gsDialogStyles
gCcontrols(0).lFontSize = 0
gCcontrols(0).sFont = ""
gCcontrols(0).sFontAtts = ""
gCcontrols(0).lFGColour = 0
gCcontrols(0).lBGColour = 0
DIALOG GET LOC CBHNDL TO gCcontrols(0).X, gCcontrols(0).Y
DIALOG GET SIZE CBHNDL TO gCcontrols(0).W, gCcontrols(0).H
gCcontrols(0).sImgPath = ""
gCcontrols(0).hFont = 0
'ghandcur = LoadCursorFromFile("handgrab.cur")
CASE %WM_ERASEBKGND
FUNCTION=0
EXIT FUNCTION
CASE %WM_CTLCOLORDLG ' paint grid if gShowGrid is on..
IF gShowGrid AND ghBrush THEN FUNCTION = ghBrush
CASE %WM_DESTROY 'delete what we created on exit, to avoid mem leaks
IF ghBrush THEN DeleteObject ghBrush
IF ghBit THEN DeleteObject SelectObject(gMemDC, ghBit)
IF gMemDC THEN DeleteDC gMemDC 'should already be deleted, but to make sure..
' killtimer CBHNDL, %TIMER_SNAP
' killtimer CBHNDL, %TIMER_REDRAW_GRID
CASE %WM_SETCURSOR
' If mouse button is pressed, over-ride default cursor and
' set "own", here cross cursor. Only shown during drawing the control.
' Note - in dialogs, we must return
' %TRUE to inform dialog engine we have taken charge. In SDK-style
' windows, we would have had to return zero and break out.
IF CBWPARAM = CBHNDL AND HIWRD(CBLPARAM) = %WM_LBUTTONDOWN THEN
IF GetCursor <> hCur THEN SetCursor hCur
FUNCTION = 1
END IF
CASE %WM_LBUTTONDOWN, %WM_LBUTTONDBLCLK 'start selrect draw
rc.ntop = 0: rc.nbottom = 0: rc.nleft = 0: rc.nright = 0
selRectBegin CBHNDL
CASE %WM_MOUSEMOVE
IF (CBWPARAM AND %MK_LBUTTON) THEN 'if mouse button is down while moved, draw rect
selRectDraw CBHNDL, LOWRD(CBLPARAM), HIWRD(CBLPARAM), RC
END IF
CASE %WM_MOUSEACTIVATE ' cursor in an inactive child window
LOCAL p_CrsInSCreen, p_ClientOffset AS POINTAPI
LOCAL hWndCtrl AS LONG
IF iswindow(ghSCDialog) THEN
DIALOG END ghSCDialog, 0 ' kill off showcontrols dialog if it already exists
END IF
GetCursorPos( p_CrsInScreen )
ClientToScreen( CBHNDL, p_ClientOffset )
hWndCtrl = ChildWindowFromPoint( CBHNDL, p_CrsInScreen.X - p_ClientOffset.X, _
p_CrsInScreen.Y - p_ClientOffset.Y )
' exit if cursor is not in a valid Ccontrol!
IF CCIndexFromhW ( hWndCtrl ) = 0 THEN
FUNCTION = 0
EXIT FUNCTION
END IF
' exit if cursor is in menu
'IF (hWndCtrl = ghMenuDialog) THEN
' FUNCTION = %MA_NOACTIVATEANDEAT
' EXIT FUNCTION
'END IF
'
SELECT CASE HI(WORD, CBLPARAM) ' mouse message
CASE %WM_LBUTTONDOWN, %WM_LBUTTONDBLCLK
' If the cursor is in the client area of the CC dialog, then force drag.
' Otherwise, pass message through so dialog gets resived.
' NB control is resized to dialog dimensions on %WM_EXITSIZEMOVE
' in the callback for CCdialog.
' if iswindow(ghCCDialog) then
' DIALOG END ghCCDialog, 0 ' kill off showcontrols dialog if it already exists
' end if
IF LO(WORD,CBLPARAM) <> %HTCLIENT THEN
ghCCDialog = hWndCtrl
FUNCTION = %MA_ACTIVATE ' NO, let message through for resize
ELSE
'setcursor hCur
PostMessage hWndCtrl, %WM_NCLBUTTONDOWN, %HTCAPTION, 0 ' YES, FORCE DRAG
ghCCDialog = hWndCtrl
FUNCTION = %MA_NOACTIVATEANDEAT
EXIT FUNCTION
END IF
CASE %WM_RBUTTONDOWN, %WM_RBUTTONDBLCLK
ghCCDialog = hWndCtrl
hPopup& = CreatePopupMenu
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 1, "Properties")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND OR %MF_GRAYED, 2, "Cut")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND, 3, "Copy")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND OR %MF_GRAYED, 4, "Paste")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND OR %MF_GRAYED, 5, "Select All")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND, 6, "Delete")
CALL GetCursorPos(BYREF p)
MenuChoice = TrackPopupMenuEx(hPopup&, %MF_ENABLED OR %MF_BYCOMMAND OR %TPM_RETURNCMD, p.x, p.y, CBHNDL, BYVAL %NULL)
CALL DestroyMenu(hPopup)
SELECT CASE menuchoice
CASE 1 ' Properties
glDIALOGPROPERTIES = %FALSE
ShowProp(CBHNDL)
CASE 3 ' Copy
CopyControl ( CBHNDL, hWndCtrl )
CASE 6 ' Delete
CONTROL KILL CBHNDL, %idc_CCID ' kill control
RemoveCCFromTable(hWndCtrl) ' remove from table
DIALOG END hwndCtrl, 0 ' kill dialog
END SELECT
FUNCTION = %MA_NOACTIVATEANDEAT ' that's all for right click
END SELECT
CASE %WM_RBUTTONDOWN, %WM_RBUTTONDBLCLK
IF iswindow(ghSCDialog) THEN
DIALOG END ghSCDialog, 0 ' kill off showcontrols dialog if it already exists
END IF
l = showCControls(CBHNDL)
CASE %WM_LBUTTONUP 'mouse button released - end draw
IF selRectEnd( CBHNDL, RC) = 0 THEN
FUNCTION = 1
EXIT FUNCTION
END IF
snap2grid(ghCCDialog)
' Now, when mouse button is released, global RECT (gRc)
' will hold coordinates of final drawn rect. If you
' for example want to select a group of controls or
' other objects, you can use IntersectRect API to see
' if parts of other RECT's are withing this global rect.
' Or use the coordinates to create a control/object of
' this size, whatever..
CASE %WM_PAINT
CASE %WM_CTLCOLORSTATIC
CASE %WM_NCRBUTTONDOWN
glDIALOGPROPERTIES = %TRUE
hPopup& = CreatePopupMenu
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 1, "Properties")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 2, "Save " + g_app_name)
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 3, "Save as..")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 4, "Load")
CALL InsertMenu(hPopup&, 0, %MF_BYCOMMAND , 5, "Export PB source")
CALL GetCursorPos(BYREF p)
MenuChoice = TrackPopupMenuEx(hPopup&, %MF_ENABLED OR %MF_BYCOMMAND OR %TPM_RETURNCMD, p.x, p.y, CBHNDL, BYVAL %NULL)
CALL DestroyMenu(hPopup)
SELECT CASE menuchoice
CASE 1 ' Properties
glDIALOGPROPERTIES = %TRUE
ShowProp(CBHNDL)
CASE 2 ' Save
SaveCCs(CBHNDL, g_app_name)
CASE 3 ' Save As
SaveCCs(CBHNDL, "")
CASE 4 ' Load
LoadCCs(CBHNDL)
CASE 5 ' Export PB Source code
ExportPBSource(CBHNDL)
END SELECT
FUNCTION = %MA_NOACTIVATEANDEAT ' that's all for right click
END SELECT
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' initialize sel rect drawing
' Copy dialog to global "screen buffer" for use as base for flicker
' free drawing and later restore.
'--------------------------------------------------------------------
SUB selRectBegin (BYVAL hWnd AS DWORD)
LOCAL hDC AS DWORD, hBit AS DWORD, pt AS POINTAPI, rc AS RECT
SetCapture hWnd ' set capture to desired window
GetClientRect hWnd, rc ' get client size
MapWindowPoints hWnd, 0, rc, 2 ' map client coordiantes to screen
ClipCursor rc ' clip cursor to client coordinates
GetCursorPos gPt ' get cursor pos on screen
ScreenToClient hWnd, gPt ' convert to client coordinates
IF gSnapToGrid THEN
gPt.x = (gPt.x \ gGridSizeX) * gGridSizeX ' if snap to grid, calculate "grid'd pos"
gPt.y = (gPt.y \ gGridSizeY) * gGridSizeY ' via multiply of integer divide result
END IF
GetClientRect hWnd, rc 'create a global memDC and copy window to it.
hDC = GetDc(hWnd)
gMemDC = CreateCompatibleDC (hDC)
ghBit = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
ghBit = SelectObject(gMemDC, ghBit)
BitBlt gMemDC, 0, 0, rc.nRight, rc.nBottom, hDC, 0, 0, %SRCCOPY
ReleaseDc hWnd, hDC
END SUB
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' perform sel rect drawing
'--------------------------------------------------------------------
SUB selRectDraw (BYVAL hWnd AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG, RCT AS RECT)
LOCAL hDC AS DWORD, hBrush AS DWORD, hPen AS DWORD, rc AS RECT
LOCAL memDC AS DWORD, hBit AS DWORD
IF gSnapToGrid THEN
' MS cross cursor has mis-aligned hotspot - it should be at
' cross, but is upper-left corner. We should use own cross,
' but this is just a sample, so instead cheat and add 4 to pos..
x = x + 4 '<- depends on where hotspot in cursor is..
y = y + 4
x = (x \ gGridSizeX) * gGridSizeX 'first integer divide, then multiply for "grid effect".
y = (y \ gGridSizeY) * gGridSizeY
END IF
' must make sure rect coordinates are correct,
' so right side always is larger than left, etc.
IF (gPt.x <= x) AND (gPt.y >= y) THEN
SetRect gRc, gPt.x, y, x, gPt.y
ELSEIF (gPt.x > x) AND (gPt.y > y) THEN
SetRect gRc, x, y, gPt.x, gPt.y
ELSEIF (gPt.x >= x) AND (gPt.y <= y) THEN
SetRect gRc, x, gPt.y, gPt.x, y
ELSE
SetRect gRc, gPt.x, gPt.y, x, y
END IF
GetClientRect hWnd, rc
IF gRc.nLeft = gRc.nRight THEN INCR gRc.nRight '<- ensure we never get a "null rect"
IF gRc.nTop = gRc.nBottom THEN INCR gRc.nBottom
hDC = GetDc(hWnd)
memDC = CreateCompatibleDC (hDC) 'create temporary memDC to draw in
hBit = CreateCompatibleBitmap(hDC, rc.nRight, rc.nBottom)
hBit = SelectObject(memDC, hBit)
hBrush = SelectObject(memDC, GetStockObject(%NULL_BRUSH)) 'for hollow rect
BitBlt memDC, 0, 0, rc.nRight, rc.nBottom, gMemDC, 0, 0, %SRCCOPY 'copy original buffer to temp DC
hPen = SelectObject(memDC, CreatePen(%PS_SOLID, 2, GetSysColor(%COLOR_3DSHADOW))) 'create pen
Rectangle memDC, gRc.nLeft, gRc.nTop, gRc.nRight + 1, gRc.nBottom + 1 'draw rect
SETRECT RCT, gRc.nLeft, gRc.nTop, gRc.nRight + 1, gRc.nBottom + 1
DeleteObject SelectObject(memDC, hPen)
BitBlt hDC, 0, 0, rc.nRight, rc.nBottom, memDC, 0, 0, %SRCCOPY 'copy temp DC to window
SelectObject memDC, hBrush
IF hBit THEN DeleteObject SelectObject(memDC, hBit) 'clean up to avoid mem leaks
IF memDC THEN DeleteDC memDC
ReleaseDc hWnd, hDC
END SUB
'------------------------------------------------------------------------------
' this callback function assumes that the dialog has been added to the gCControls table
' it is used for all ccontrols, so should not use any statics or globals (except gCControls)
'
CALLBACK FUNCTION CC_dialogProc()
LOCAL r AS rect
LOCAL w, h, l, lCX, x, y AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
' Initialization handler
Snap2Grid (CBHNDL)
ghCCDialog = CBHNDL
DIALOG GET CLIENT CBHNDL TO W, H
DIALOG GET LOC CBHNDL TO X, Y
CONTROL SET SIZE CBHNDL, %idc_ccID, w, h
CONTROL SET LOC CBHNDL, %IDC_CCID, 0, 0
l = CCindexfromhW ( CBHNDL)
gCcontrols(l).hcurs = loadcursor(0, BYVAL %IDC_SIZEALL)
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
CASE %WM_EXITSIZEMOVE ' ccontrol has been dragged or sized AFTER first drawn
DIALOG GET CLIENT CBHNDL TO W, H
'DIALOG GET LOC CBHNDL TO X, Y
CONTROL SET SIZE CBHNDL, %idc_ccID, w, h
CONTROL SET LOC CBHNDL, %IDC_CCID, 0, 0
snap2grid(CBHNDL)
CASE %WM_NCLBUTTONDOWN
lCX = CCIndexfromhW(CBHNDL)
setcursor(gCcontrols(lCX).hCurs)
CASE %WM_LBUTTONDOWN
SendMessage CBHNDL, %WM_NCLBUTTONDOWN, %HTCAPTION, BYVAL %NULL ' force drag
CASE %WM_LBUTTONUP
snap2grid(CBHNDL)
CASE %WM_DESTROY 'delete what we created on exit, to avoid mem leaks
lCX = CCIndexfromhW(CBHNDL)
IF gCcontrols(lCX).hFont <> 0 THEN deleteObject gCcontrols(lCX).hFont
IF gCcontrols(lCX).hCurs <> 0 THEN deleteObject gCcontrols(lCX).hcurs
END SELECT
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' end sel rect drawing
' Copy original window buffer back to screen to wipe out drawn
' rectangle, delete global memDC, release capture and clipped cursor.
'--------------------------------------------------------------------
FUNCTION selRectEnd (BYVAL hWnd AS DWORD, RCT AS RECT) AS LONG
LOCAL hDC AS DWORD, rc AS RECT
LOCAL hCCDD AS DWORD' dialog handle for control container
LOCAL lCtrlType, lRslt, CheckState AS LONG
LOCAL s, sTxt AS STRING
LOCAL l, X, Y, W, H AS LONG ' new dialog coords in UNITS
LOCAL lstyle AS LONG ' style attributes to add to window style acc to control type request
' assume tiny controls are accidental
IF (rct.nright - rct.nleft) * (rct.nbottom-rct.ntop) < 4 THEN
ReleaseCapture' or we are stuck with wrong cursor, etc
EXIT FUNCTION
END IF
FUNCTION = %TRUE
'
hDC = GetDc(hWnd)
GetClientRect hWnd, rc
BitBlt hDC, 0, 0, rc.nRight, rc.nBottom, gMemDC, 0, 0, %SRCCOPY
ReleaseDc hWnd, hDC
IF ghBit THEN DeleteObject SelectObject(gMemDC, ghBit) : ghBit = 0
IF gMemDC THEN DeleteDC gMemDC : gMemDC = 0
ReleaseCapture
FOR lCtrlType = %IDC_CTL1 TO %IDC_CTL6
CONTROL GET CHECK ghMenuDialog, lCtrlType TO CheCkState
IF CheckSTate THEN
' create a dialog to contain the selected type of control
DIALOG PIXELS hwnd, RCt.nleft, rct.ntop TO UNITS X, Y
DIALOG PIXELS hwnd, rct.nright-rct.nleft, rct.nbottom-rct.ntop TO UNITS W, H
AddCControl( lCtrlType - %our_typecontrol_base, X, Y, W, H)
END IF
NEXT lCtrlType
ClipCursor BYVAL %NULL
END FUNCTION
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Create a patterned brush for grid. By using this, grid draw becomes
' very quick, even on full size dialogs. Must warn though - in Win95,
' brush can be max 8x8 pixels. In Win98 and later, brush can be bigger,
' so never a problem there.
'--------------------------------------------------------------------
FUNCTION MakeGridBrush(BYVAL hDlg AS DWORD) AS DWORD
LOCAL hDC AS DWORD, memDC AS DWORD, hBit AS DWORD, hBitOld AS DWORD, rc AS RECT
LOCAL lpx, lpy AS LONG
hDC = GetDC(hDlg)
memDC = CreateCompatibleDC(hDC)
DIALOG UNITS hdlg, gGridSizeX, gGridSizeY TO PIXELS lpX, lpY
hBit = CreateCompatibleBitmap(hDC, lpX, lpY)
hBitOld = SelectObject(memDC, hBit)
rc.nRight = lpX
rc.nBottom = lpY
FillRect memDC, rc, GetSysColorBrush(%COLOR_3DFACE)
SetPixelV memDC, 0, 0, 0 'paint "dots" in all four corners
SetPixelV memDC, 0, lpY, 0
SetPixelV memDC, lpX, 0, 0
SetPixelV memDC, lpX, lpY, 0
FUNCTION = CreatePatternBrush (hBit)
SelectObject memDC, hBitOld 'clean up to avoid mem leaks
DeleteObject hBit
DeleteDC memDC
ReleaseDC hDlg, hDC
END FUNCTION
'------------------------------------------------------------------------------
CALLBACK FUNCTION FloatMenu_dialogProc()
STATIC hmenu, hparent AS DWORD
LOCAL r AS rect
LOCAL s, s1 AS STRING
LOCAL l AS LONG
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
' Initialization handler
ghMenuDialog = CBHNDL
hParent = GetParent (CBHNDL)
CONTROL GET CHECK CBHNDL, %idc_chk1 TO gSnapToGrid
CONTROL GET CHECK CBHNDL, %idc_chk2 TO gShowgrid
CONTROL GET CHECK CBHNDL, %idc_chk3 TO gSize2Grid
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
CASE %WM_LBUTTONDOWN
SendMessage CBHNDL, %WM_NCLBUTTONDOWN, %HTCAPTION, BYVAL %NULL ' force drag
CASE %WM_DESTROY 'delete what we created on exit, to avoid mem leaks
CASE %WM_COMMAND
SELECT CASE CBCTL ' <- look at control's id
CASE %IDC_CHK1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gSnapToGrid
END IF
CASE %IDC_CHK2
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gShowGrid
IF gShowGrid <> 0 THEN
CONTROL GET TEXT CBHNDL, %IDC_gridX_tb TO s ' redraw grid
CONTROL GET TEXT CBHNDL, %IDC_gridY_tb TO s1
gGridSizeX = VAL(s)
gGridSizeY = VAL(s1)
gCcontrols(0).lGridX = gGridSizeX
gCcontrols(0).lGridY = gGridSizeY
IF ghBrush THEN DeleteObject ghBrush
ghBrush = MakeGridBrush (ghMainDD) ' and create grid brush for main dialog
IF gSnapToGrid THEN
FOR l = 0 TO gCCX
Snap2Grid ( gCControls(l).hD )
NEXT
END IF
END IF
RedrawWindow hparent, BYVAL %NULL, 0, %RDW_ERASE OR %RDW_INVALIDATE OR %RDW_UPDATENOW
END IF
CASE %IDC_CHK1
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gSnapToGrid
END IF
CASE %IDC_CHK3
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
CONTROL GET CHECK CBHNDL, CBCTL TO gSize2Grid
END IF
CASE %IDC_gridx_tb
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN 'end prog
END IF
END SELECT
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION FloatMenu_dialog(BYVAL hParent AS DWORD) AS LONG
LOCAL lRslt AS LONG
LOCAL hDlg AS DWORD
DIALOG NEW hParent, "", 570, 100, 65, 140, %WS_POPUP OR %WS_THICKFRAME OR _
%WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_TOOLWINDOW OR _
%WS_EX_TOPMOST OR %WS_EX_LEFT OR %WS_EX_LTRREADING TO hdlg
'OR _
'%WS_EX_RIGHTSCROLLBAR, TO hDlg
DIALOG SET COLOR hDlg, -1, RGB(255, 255, 155)
CONTROL ADD CHECKBOX, hDlg, %IDC_CHK1, "&Snap to grid ", 2, 5, 60, 10
CONTROL ADD CHECKBOX, hDlg, %IDC_CHK2, "S&how grid ", 2, 15, 60, 10
CONTROL ADD CHECKBOX, hDlg, %IDC_CHK3, "Si&ze to grid ", 2, 25, 60, 10
CONTROL SET CHECK hDlg, %IDC_CHK1, 1
CONTROL SET CHECK hDlg, %IDC_CHK2, 1
CONTROL SET CHECK hDlg, %IDC_CHK3, 1
CONTROL ADD LABEL, hDlg, %IDC_LAB1, "Grid size X" , 2, 50, 38, 10
CONTROL ADD TEXTBOX, hDlg, %IDC_gridx_tb, TRIM$(STR$(gGridSizeX)) ,45, 50, 16, 10, %ES_NUMBER
CONTROL ADD LABEL, hDlg, %IDC_LAB2, "Grid size Y" ,2 , 60, 38, 10
CONTROL ADD TEXTBOX, hDlg, %IDC_gridy_tb, TRIM$(STR$(gGridSizeY)) ,45, 60, 16, 10, %ES_NUMBER
CONTROL ADD OPTION, hDlg, %IDC_CTL1, "&Label", 2, 75, 60, 10
CONTROL ADD OPTION, hDlg, %IDC_CTL2, "&Text Box", 2, 85, 60, 10
CONTROL ADD OPTION, hDlg, %IDC_CTL3, "&CheckBox", 2, 95, 60, 10
CONTROL ADD OPTION, hDlg, %IDC_CTL4, "&Listbox", 2, 105, 60, 10
CONTROL ADD OPTION, hDlg, %IDC_CTL5, "List&view", 2, 115, 60, 10, %WS_GROUP
CONTROL ADD OPTION, hDlg, %IDC_CTL6, "&Button", 2, 125, 60, 10
CONTROL SET OPTION hDlg, %IDC_CTL1, %IDC_CTL1, %IDC_CTL3 ' set initial state
DIALOG SHOW MODELESS hDlg, CALL FloatMenu_dialogProc TO lRslt
FUNCTION = lRslt
END FUNCTION
'------------------------------------------------------------------------------
' turn col & row coords into data from the gCControls table
FUNCTION get_x_item ( col AS LONG, row AS LONG ) AS STRING
LOCAL s AS STRING
LOCAL lrow AS LONG
lrow = row '+ 1
SELECT CASE AS LONG col
CASE 0
s = USING$("########", gCControls(lrow).hD) ' HD
CASE 1
s = USING$("###", gCControls(lrow).Cid) ' Control id
CASE 2
S = gsControlTypes(gCControls(lrow).lCtrlType)
CASE 3
s = gCControls(lrow).sText
CASE 4
s = gCControls(lrow).sStyles
CASE 5
s = USING$("##", gCControls(lrow).lFontSize)
CASE 6
s = gCControls(lrow).sFont
CASE 7
s = gCControls(lrow).sFontAtts
CASE 8
s = HEX$(gCControls(lrow).lFGColour, 6) ' FGColour
CASE 9
s = HEX$(gCControls(lrow).lBGCOlour,6) ' BGColour
CASE 10
s = USING$("####", gCControls(lrow).X) ' X
CASE 11
s = USING$("####", gCControls(lrow).Y) ' Y
CASE 12
s = USING$("####", gCControls(lrow).W) ' W
CASE 13
s = USING$("####", gCControls(lrow).H) ' H
END SELECT
FUNCTION = s
END FUNCTION
'--------------------------------------------------------------------------------
' from Stan Durham's source code posting Xmas 2006
FUNCTION SDMakeFont(BYVAL sFontName AS STRING, BYVAL nPointSize AS LONG, BYVAL bIsBold AS LONG, BYVAL bIsItalic AS LONG, BYVAL bIsUnderline AS LONG ) AS LONG
LOCAL hDC AS LONG, CyPixels AS LONG
hDC = GetDC(%HWND_DESKTOP)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
ReleaseDC %HWND_DESKTOP, hDC
nPointSize = (nPointSize * CyPixels) \ 72
FUNCTION = CreateFont(0 - nPointSize, 0, 0, 0, IIF&(bIsBold, %FW_BOLD, %FW_NORMAL), bIsItalic, bIsUnderline, 0, _
%ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
%DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY sFontName)
END FUNCTION
'------------------------------------------------------------------------------
' ListView Custom Draw controls table
FUNCTION LVCC ( BYVAL ptlvcd AS NMLVCUSTOMDRAW PTR ) AS LONG
LOCAL szItem AS ASCIIZ * %MAX_PATH ' item text
LOCAL trcItem AS RECT ' bounding rectangle of item/subitem
LOCAL tlv_item AS LV_ITEM ' listview item information
LOCAL tlb AS LOGBRUSH ' specifies information used to create background brush
LOCAL hWndHdr AS DWORD ' handle of header child control
LOCAL hBrush AS DWORD
LOCAL hBrushOld AS DWORD
LOCAL hPenOld AS DWORD
LOCAL dwBackColor AS DWORD
LOCAL nBkModeOld AS INTEGER
LOCAL hfont AS LONG
' Get the item or subitem info
tlv_item.mask = %LVIF_TEXT OR %LVIF_IMAGE OR %LVIF_STATE
tlv_item.stateMask = %LVIS_FOCUSED OR %LVIS_SELECTED
tlv_item.iItem = @ptlvcd.nmcd.dwItemSpec
tlv_item.iSubItem = @ptlvcd.iSubItem
tlv_item.pszText = VARPTR(szItem)
tlv_item.cchTextMax = %MAX_PATH
SendMessage @ptlvcd.nmcd.hdr.hwndFrom, %LVM_GETITEM, 0, BYVAL VARPTR(tlv_item)
' set up font
hFont = SDMakeFont("courier new", 9, 0, 0, 0)
SendMessage @ptlvcd.nmcd.hdr.hwndFrom, %WM_SETFONT, hFont, 0
' Get the bounding rectangle of the subitem(cell)
trcItem.nLeft = %LVIR_BOUNDS
trcItem.nTop = @ptlvcd.iSubItem
SendMessage @ptlvcd.nmcd.hdr.hwndFrom, %LVM_GETSUBITEMRECT, @ptlvcd.nmcd.dwItemSpec, BYVAL VARPTR(trcItem)
tlb.lbStyle = %BS_SOLID
dwBackColor = RGB(236,189,147) ' salmon pink background
tlb.lbColor = dwBackColor
tlb.lbHatch = 0
hBrush = CreateBrushIndirect(tlb)
FillRect @ptlvcd.nmcd.hdc, trcItem, hBrush
DeleteObject hBrush
' Draw the text
nBkModeOld = SetBkMode(@ptlvcd.nmcd.hdc, %TRANSPARENT)
DrawTextEx @ptlvcd.nmcd.hdc, szItem, LEN(szItem), trcItem, %DT_SINGLELINE OR %DT_LEFT OR %DT_VCENTER OR %DT_END_ELLIPSIS, BYVAL %NULL
SetBkMode @ptlvcd.nmcd.hdc, nBkModeOld
' Draw focus rectangle
' Note: it is drawn when the last column is painted.
IF (tlv_item.STATE AND %LVIS_FOCUSED) = %LVIS_FOCUSED THEN
hWndHdr = SendMessage(@ptlvcd.nmcd.hdr.hwndFrom, %LVM_GETHEADER, 0, 0)
IF @ptlvcd.iSubItem = SendMessage(hWndHdr, %HDM_GETITEMCOUNT, 0, 0) - 1 THEN
' Get the bounding rectangle of the entire item(this includes all subitems)
trcItem.nLeft = %LVIR_BOUNDS
SendMessage @ptlvcd.nmcd.hdr.hwndFrom, %LVM_GETITEMRECT, @ptlvcd.nmcd.dwItemSpec, BYVAL VARPTR(trcItem)
' Black pen 2 pixels thick
hPenOld = SelectObject(@ptlvcd.nmcd.hdc, CreatePen(%PS_SOLID, 3 * GetSystemMetrics(%SM_CXBORDER), &H8c08c08c0???))
' A hollow brush is used to avoid erasing what was painted already
hBrushOld = SelectObject(@ptlvcd.nmcd.hdc, GetStockObject(%NULL_BRUSH))
' Rectangle @ptlvcd.nmcd.hdc, trcItem.nLeft, trcItem.nTop, trcItem.nRight, trcItem.nBottom
' modifed rectanlge to give an underscore
rectangle @ptlvcd.nmcd.hdc, trcItem.nLeft, trcItem.nbottom-1, trcItem.nRight, trcItem.nBottom
SelectObject @ptlvcd.nmcd.hdc, hBrushOld
DeleteObject SelectObject(@ptlvcd.nmcd.hdc, hPenOld)
END IF
END IF
FUNCTION = %CDRF_SKIPDEFAULT
END FUNCTION
'---------------------------------------------------------------------------------------
SUB InitSCLV ( hD AS DWORD )
LOCAL lCol, lRow, lcolcnt, lrowcnt, X, Y AS LONG
LOCAL hCtl, hSCDD AS DWORD
LOCAL tLVC AS LV_COLUMN
LOCAL tLVI AS LV_ITEM
LOCAL szBuf AS ASCIIZ * 32
LOCAL lStyle AS LONG
CONTROL HANDLE hD, %IDC_SHOWCONTROLS_LV TO hCtl
lStyle = ListView_GetExtendedListViewStyle(hCtl)
lStyle = lStyle OR %LVS_EX_GRIDLINES OR %LVS_EX_FULLROWSELECT OR %LVS_EX_UNDERLINEHOT _
OR %LVS_EX_ONECLICKACTIVATE OR %LVS_EX_LABELTIP 'OR %LVS_EX_FULLROWSELECT
CALL SendMessage(hCTL, %LVM_SETEXTENDEDLISTVIEWSTYLE, 0, BYVAL lStyle)
lcolcnt = 14 ' lucky for some
lrowcnt = gCCX +1
' Load column headers.
tLVC.mask = %LVCF_FMT OR %LVCF_TEXT OR %LVCF_SUBITEM
tLVC.fmt = %LVCFMT_LEFT
tLVC.pszText = VARPTR(szBuf)
szBuf = "handle" :tLVC.iOrder = 0 : ListView_InsertColumn hCtl, 0, tLVC
szBuf = "Ctrl Id" :tLVC.iOrder = 1 : ListView_InsertColumn hCtl, 2, tLVC
szBuf = "Ctrl Type" :tLVC.iOrder = 2 : ListView_InsertColumn hCtl, 3, tLVC
szBuf = "Text" :tLVC.iOrder = 3 : ListView_InsertColumn hCtl, 4, tLVC
szBuf = "Styles" :tLVC.iOrder = 4 : ListView_InsertColumn hCtl, 5, tLVC
szBuf = "Font size" :tLVC.iOrder = 5 : ListView_InsertColumn hCtl, 6, tLVC
szBuf = "Font Name" :tLVC.iOrder = 6 : ListView_InsertColumn hCtl, 7, tLVC
szBuf = "Font Attributes" :tLVC.iOrder = 7 : ListView_InsertColumn hCtl, 8, tLVC
szBuf = "FG color" :tLVC.iOrder = 8 : ListView_InsertColumn hCtl, 9, tLVC
szBuf = "BG color" :tLVC.iOrder = 9 : ListView_InsertColumn hCtl, 10, tLVC
szBuf = "TopLeft X" :tLVC.iOrder = 10 : ListView_InsertColumn hCtl, 11, tLVC
szBuf = "TopLeft Y" :tLVC.iOrder = 11 : ListView_InsertColumn hCtl, 12, tLVC
szBuf = "Width" :tLVC.iOrder = 12 : ListView_InsertColumn hCtl, 13, tLVC
szBuf = "Height" :tLVC.iOrder = 13 : ListView_InsertColumn hCtl, 14, tLVC
' Auto size columns.
FOR lCol = 0 TO lColCnt - 2
ListView_SetColumnWidth hCtl, lCol, %LVSCW_AUTOSIZE_USEHEADER
NEXT lCol
ListView_SetColumnWidth hCtl, lColCnt - 1, %LVSCW_AUTOSIZE_USEHEADER
'
CONTROL SEND hD, %IDC_SHOWCONTROLS_LV, %LVM_DELETEALLITEMS ,0,0
CONTROL SEND hD, %IDC_SHOWCONTROLS_LV, %LVM_SETITEMCOUNT, lrowcnt ,%LVSICF_NOINVALIDATEALL OR %LVSICF_NOSCROLL
END SUB
'------------------------------------------------------------------------------
CALLBACK FUNCTION SC_dialogProc()
STATIC hmenu, hparent AS DWORD
LOCAL s, s1, squery AS STRING
LOCAL l, X, Y AS LONG
LOCAL pnmh AS NMHDR PTR
LOCAL pnm AS NMLVCUSTOMDRAW PTR
' once again, one of those oh so easy to follow sturctures with sturctures
' inside them. The main thing here is that this will tell you what row & col
' is in need of filling. Row is iItem & col is iSubItem
LOCAL lpLVDispInfo AS LV_DISPINFO PTR
' an asciiz string that windows expects when you tell
' it what to show in the listview
LOCAL szString AS ASCIIZ * 256
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
' Initialization handler
hParent = GetParent (CBHNDL)
ghSCDialog = CBHNDL
DIALOG GET SIZE CBHNDL TO x, y
CONTROL SET SIZE CBHNDL, %IDC_SHOWCONTROLS_LV, x-4, y-4
InitSCLV(CBHNDL) ' set up listview header
l = gCCX
DIALOG SET TEXT CBHNDL, STR$(l)
'
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
' Save control focus
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
' Restore control focus
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
CASE %WM_NOTIFY
pnmh = CBLPARAM
SELECT CASE @pnmh.code
CASE %NM_CUSTOMDRAW
pnm = CBLPARAM
SELECT CASE @pnm.nmcd.dwDrawStage
CASE %CDDS_PREPAINT
' The following statement ensures that the relevant
' messages are coming back to Windows, so Windows
' can respond appropriately.
SetWindowLong CBHNDL,%DWL_MSGRESULT,%CDRF_NOTIFYITEMDRAW
' This statement makes the DDT engine happy:
FUNCTION = 1: EXIT FUNCTION
CASE %CDDS_ITEMPREPAINT
SetWindowLong CBHNDL,%DWL_MSGRESULT,%CDRF_NOTIFYSUBITEMDRAW
FUNCTION = 1: EXIT FUNCTION
CASE %CDDS_SUBITEM 'OR %CDDS_ITEMPREPAINT
IF @pnmh.idFrom = %IDC_SHOWCONTROLS_LV THEN
FUNCTION = LVCC(BYVAL pnm)
EXIT FUNCTION
END IF
END SELECT
'
CASE %LVN_GETDISPINFO 'Virtual ListView ask for Item text
lpLVDispInfo = CBLPARAM
IF (@lpLVDispInfo.item.mask AND %LVIF_TEXT) THEN
' Specify text to be used
IF @pnmh.idFrom = %IDC_SHOWCONTROLS_LV THEN
szString = get_x_item(@lpLVDispInfo.item.iSubItem, @lpLVDispInfo.item.iItem)
END IF
@lpLVDispInfo.item.pszText = VARPTR(szString)
END IF
END SELECT
CASE %WM_LBUTTONDOWN
SendMessage CBHNDL, %WM_NCLBUTTONDOWN, %HTCAPTION, BYVAL %NULL ' force drag
CASE %WM_DESTROY 'delete what we created on exit, to avoid mem leaks
END SELECT
END FUNCTION
'--------------------------------------------------------------------
' Popup to show the CControls table contents
'--------------------------------------------------------------------
FUNCTION ShowCControls ( BYVAL hParent AS DWORD) AS LONG
LOCAL hDlg AS DWORD
LOCAL lrslt AS LONG
DIALOG NEW hParent, "CCONTROLS DEBUG ", 40, 40, 500, 200, _
%WS_POPUP _
OR %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR %WS_CLIPSIBLINGS OR _
%WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR _
%WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hdlg
CONTROL ADD "SysListView32", hDlg, %IDC_SHOWCONTROLS_LV, "", 0,0,0,0, _
%DEFAULT_LV_STYLES OR %LVS_OWNERDATA,%DEFAULT_LV_EX_STYLES
DIALOG SHOW MODELESS hDlg, CALL SC_dialogProc TO lRslt
FUNCTION = lrslt
END FUNCTION
'----------------------------------------------------------------------------
' put the XYWH of current CControl into the global array
SUB StoreCurrentCoords ( l AS LONG)
DIALOG GET LOC ghCCDialog TO gCcontrols(l).X, gCcontrols(l).Y
DIALOG GET SIZE ghCCDialog TO gCcontrols(l).W, gCcontrols(l).H
END SUB
'-----------------------------------------------------------------------------------------------------------
' load global styles table to listview
'
'------------------------------------------------------------------------------
SUB loadStyles2ListView ( hD AS DWORD, lC AS LONG)
' LOCAL i, row, iPos AS LONG
LOCAL lvhit AS LV_HITTESTINFO, lvi AS LV_ITEM, lvc AS LV_COLUMN
LOCAL sz AS ASCIIZ * 1024, rc AS RECT
LOCAL CtrlType, hfile, lrow, lcol, l, lstyle AS LONG
LOCAL hCtl AS DWORD
LOCAL s AS STRING
CONTROL HANDLE hD, lC TO hCtl ' get window handle from listview conrol
listview_deleteallitems(hCtl)
lStyle = ListView_GetExtendedListViewStyle(hCtl)
ListView_SetExtendedListViewStyle hCtl, lStyle OR %LVS_EX_FULLROWSELECT OR %LVS_EX_GRIDLINES _
OR %LVS_EX_LABELTIP
' find out what control type we are
IF glDIALOGPROPERTIES THEN
CtrlType = 0
ELSE
l = CCIndexFromhW ( ghCCDialog )
CtrlType = gCcontrols( l ).LCtrlType
END IF
' Set column info...
sz = "Style name"
lvc.mask = %LVCF_WIDTH OR %LVCF_TEXT
lvc.pszText = VARPTR(sz)
CONTROL SEND hD, lC, %LVM_INSERTCOLUMN, 0, VARPTR(lvc)
sz = "Help text"
lvc.mask = %LVCF_WIDTH OR %LVCF_TEXT
lvc.pszText = VARPTR(sz)
CONTROL SEND hD, lC, %LVM_INSERTCOLUMN, 1, VARPTR(lvc)
LVI.stateMask = %LVIS_FOCUSED
LVI.pszText = VARPTR(sz)
LVI.iItem = lRow
' extract styles for current control type from STYLES.TXT
hfile = FREEFILE
lrow = 0
OPEN $STYLESDBPATH FOR INPUT AS #hfile
LINE INPUT #hfile, s
WHILE NOT EOF(hfile)
IF VAL(TRIM$(PARSE$(s, 1))) = CtrlType THEN
sz = PARSE$(s,2) ' style name
LVI.iSubItem = 0
LVI.lParam = lrow
LVI.mask = %LVIF_TEXT OR %LVIF_PARAM OR %LVIF_STATE
ListView_InsertItem hCtl, LVI
'
sz = RIGHT$(s, LEN(s) - INSTR(s,$DQ)) ' help text
LVI.iSubItem = 1
LVI.mask = %LVIF_TEXT
ListView_SetItem hCtl, LVI
INCR lrow
END IF
LINE INPUT #hfile, s
WEND
CLOSE #hfile
' Auto size columns.
ListView_SetColumnWidth hCtl, 0, %LVSCW_AUTOSIZE_USEHEADER
ListView_SetColumnWidth hCtl, 1, %LVSCW_AUTOSIZE_USEHEADER
END SUB
'------------------------------------------------------------------------------
' this adjusts the height of the textbox to receive the string S.
' It assumes that on entry S has the maximum height
SUB SqueezeTB2Text ( hD AS DWORD, hC AS LONG, s AS STRING )
LOCAL hWndTxt AS DWORD
LOCAL rc, rcTxt1, rcTxt2 AS rect
LOCAL NCHeight, row AS LONG
'local txt as string
LOCAL szText AS ASCIIZ*1024
LOCAL hDC AS DWORD
LOCAL hFont AS LONG
LOCAL nWidth AS LONG
LOCAL nHeight AS LONG
LOCAL hFontOld AS LONG
LOCAL x, y, xx, yy AS LONG
CONTROL HANDLE hD, hC TO hWndTxt
GetWindowRect hWndTXT, rcTxt1
GetClientRect hWndTXT, rcTxt2
MapWindowPoints %HWND_DESKTOP, hD, rcTxt1, 2
MapWindowPoints %HWND_DESKTOP, hD, rcTxt2, 2
NCHeight = (rcTxt1.nBottom-rcTxt1.nTop)-(rcTxt2.nBottom-rcTxt2.nTop)
'CONTROL GET TEXT hD, hC TO txt
IF s = "" THEN EXIT SUB
szText = s
hFont=SendMessage(hWndTXT, %WM_GETFONT, 0, 0)
hDC=GetDC(hWndTXT)
hFontOld=SelectObject(hDC, hFont)
TYPE SET rc=rcTxt2
DrawText hDC, szText, LEN(szText), rc, %DT_CALCRECT OR %DT_WORDBREAK
SelectObject hDC, hFontOld
ReleaseDC hWndTXT, hDC
x=rcTxt1.nLeft
y=rcTxt1.nTop
xx=(rcTxt1.nRight-rcTxt1.nLeft)
yy=(rc.nBottom-rc.nTop)+(NCHeight*2)
IF (yy - (NCHeight*2)) < (rcTxt2.nbottom - rcTxt2.ntop) THEN
MoveWindow hWndTXT, x, y, xx, yy, %TRUE
END IF
CONTROL SET TEXT hD, hC, s
END SUB
'--------------------------------------------------------------------
' select colour, return RGB code as atring
FUNCTION SelColour( hD AS DWORD) AS STRING
STATIC CCA AS CHOOSECOLORAPI
LOCAL lResult AS LONG
STATIC clrRef() AS DWORD ' colorref
DIM clrRef(0 TO 16) AS STATIC DWORD 'colorref
CCA.lStructSize = LEN(CCA)
CCA.hwndOwner = hD
CCA.lpCustColors = VARPTR(ClrRef())
CCA.rgbResult = getsyscolor(%color_3dface)
CCA.Flags = CCA.Flags OR %CC_RGBINIT 'or %CC_FULLOPEN
lResult = ChooseColor(CCA)
IF lResult <> 0 THEN 'check if user cancelled dialog ?
FUNCTION = HEX$(CCA.rgbResult,6)
'to get RGB sequence, use RIGHT$(ClrStr,2) + MID$(ClrStr,3,2) + LEFT$ (ClrStr,2)
END IF
END FUNCTION
'----------------------------------------------------------------------------
SUB ReFont ( hD AS DWORD, hC AS LONG, hFont AS LONG, sFont AS STRING, lFontsize AS LONG, _
lBold AS LONG, lItalic AS LONG, lUnderline AS LONG, lFGcolour AS LONG, lBGColour AS LONG)
IF hFont <> 0 THEN
deleteObject hfont
END IF
hFont = SDMakeFont(sFont, lfontsize, lbold, litalic, lunderline)
CONTROL SEND hD, hC, %WM_SETFONT, hFont, 0
CONTROL SET COLOR hD, hC, lfgcolour, lbgcolour
CONTROL REDRAW hD, hC
END SUB
'----------------------------------------------------------------------------
' parameters : dialog, listview Styles control, gCControls index, styles string
' if styles string is null, use default styles
' select rows in listview corresponding to default styles for current control
' return handle to listview
FUNCTION SelDefaultStyles ( hD AS DWORD, lC AS LONG, lcx AS LONG, sTyles AS STRING) AS LONG
LOCAL s AS STRING
LOCAL i, hlistview, row AS LONG
LOCAL lvf AS LVFindInfo
LOCAL sz AS ASCIIZ * 1024
CONTROL HANDLE hD, lC TO hListView
FUNCTION = hListView
IF sTyles = "" THEN ' use default styles
SELECT CASE gCcontrols(lCX).lCtrlType
CASE %our_dialog_type
s = $DEFAULT_DLG_STYLES
CASE %our_label_type
s = $DEFAULT_LAB_STYLES
CASE %our_textbox_type
s = $DEFAULT_TB_STYLES
CASE %our_checkbox_type
s = $DEFAULT_CB_STYLES
CASE %our_listbox_type
s = $DEFAULT_LB_STYLES
CASE %our_listview_type
s = $DEFAULT_LV_STYLES
CASE %our_button_type
s = $DEFAULT_BN_STYLES
END SELECT
ELSE
s = sTyles
END IF
ListView_SetItemState (hListView, -1, %NULL, %LVIS_SELECTED OR %LVIS_FOCUSED)' turn all off
FOR i = 1 TO PARSECOUNT(s)
sz = PARSE$(s,i)
LVF.flags = %LVFI_STRING
LVF.psz = VARPTR(sz)
row = Listview_FindItem ( hListView, -1, LVF)
IF row <> -1 THEN
ListView_SetItemState (hListView, row, %LVIS_SELECTED OR %LVIS_FOCUSED, %LVIS_SELECTED OR %LVIS_FOCUSED)
END IF
NEXT
CONTROL SET FOCUS hD, lC
END FUNCTION
'----------------------------------------------------------------------------
CALLBACK FUNCTION ShowPROPProc()
STATIC lCX, row AS LONG
LOCAL LVF AS lVFindInfo
LOCAL s AS STRING
STATIC hTBW, hListView AS LONG
LOCAL lvhit AS LV_HITTESTINFO, lvi AS LV_ITEM, lvc AS LV_COLUMN
LOCAL sz AS ASCIIZ * 1024, rc AS RECT
STATIC hFont, i, lbgcolour, lfgcolour, lbold, litalic, lunderline, lfontsize AS LONG
STATIC sfont AS STRING
STATIC pCFS AS CHOOSEFONTAPI POINTER
STATIC pLF AS LOGFONT POINTER
STATIC hParent AS DWORD
SELECT CASE AS LONG CBMSG
CASE %WM_INITDIALOG
lFGColour = getsyscolor(%COLOR_WINDOWTEXT)
lBGColour = getsyscolor(%COLOR_3dface)
hParent = getParent(CBHNDL)
ghPROPDD = CBHNDL
IF glDIALOGPROPERTIES = %TRUE THEN
lCX = 0
ELSE
lCX = CCIndexfromhW ( ghCCDialog) ' get index to GCControls table
END IF
StoreCurrentCoords(lCX) ' put XYWH into gCcontrols()
LoadStyles2ListView(CBHNDL, %IDC_AV_STYLES_LV)
'CONTROL HANDLE CBHNDL, %IDC_STYLES_TB TO hTBW
'CONTROL HANDLE CBHNDL, %IDC_AV_STYLES_LV TO hListView
' populate controls from CcControls table
CONTROL SET TEXT CBHNDL, %IDC_TEXT_TB, TRIM$(gCcontrols(lCX).sText)
'
s = TRIM$(gCcontrols(lCX).sStyles)
hListView = SelDefaultStyles ( CBHNDL, %IDC_AV_STYLES_LV, lCX, s )
sFont = gCcontrols(lCX).sFont
CONTROL SET TEXT CBHNDL, %IDC_FONT_BN, sFont
CONTROL SET TEXT CBHNDL, %IDC_LABEL1, "Dialog Id " + STR$(gCcontrols(lCX).hD)
CONTROL SET TEXT CBHNDL, %IDC_CTRL_NO_LAB, "Control Number" + STR$(gCcontrols(lCX).Cid)
CONTROL SET TEXT CBHNDL, %IDC_CTRL_TYPE_LAB, "Type of Control " + gsControlTypes(gCcontrols(lCX).lCtrlType)
lfontsize = gCcontrols(lCX).lFontSize
CONTROL SET TEXT CBHNDL, %IDC_FONTSIZE_LAB, STR$(lFontSize)
s = gCcontrols(lCX).sFontAtts
lunderline= %FALSE: litalic = %FALSE: lbold = %FALSE
IF INSTR(s, "bold") THEN lbold = %TRUE
IF INSTR(s, "italic") THEN litalic = %TRUE
IF INSTR(s, "underline") THEN lunderline = %TRUE
CONTROL SET TEXT CBHNDL, %IDC_FONTATTS_LAB, s
gCcontrols(lCX).lBGColour = lBGColour
gCcontrols(lCX).lFGColour = lFGcolour
CONTROL SET TEXT CBHNDL, %IDC_BGCOLOR_BN, "background:" + HEX$(gCcontrols(lCX).lBGColour,6)
CONTROL SET TEXT CBHNDL, %IDC_FONTATTS_LAB, gCcontrols(lCX).sFontAtts
CONTROL SET TEXT CBHNDL, %IDC_X_LAB, "X=" + STR$(gCcontrols(lCX).X)
CONTROL SET TEXT CBHNDL, %IDC_Y_LAB, "Y=" + STR$(gCcontrols(lCX).Y)
CONTROL SET TEXT CBHNDL, %IDC_W_LAB, "W=" + STR$(gCcontrols(lCX).W)
CONTROL SET TEXT CBHNDL, %IDC_H_LAB, "H=" + STR$(gCcontrols(lCX).H)
hFont = gCcontrols(lCX).hFont
ReFont (CBHNDL, %IDC_TEXT_TB, hFont, sFont, lFontSize, lbold, lItalic, lUnderline, lFGCOlour, lBGColour)
CASE %WM_DESTROY
' don't delete the font here! do it in the callback function for the CCDialog!
CASE %WM_NCACTIVATE
STATIC hWndSaveFocus AS DWORD
IF ISFALSE CBWPARAM THEN
hWndSaveFocus = GetFocus()
ELSEIF hWndSaveFocus THEN
SetFocus(hWndSaveFocus)
hWndSaveFocus = 0
END IF
'
CASE %WM_COMMAND
SELECT CASE AS LONG CBCTL
CASE %IDC_DEF_STYLES_BN
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN 'end prog
LoadStyles2ListView(CBHNDL, %IDC_AV_STYLES_LV)
SelDefaultStyles ( CBHNDL, %IDC_AV_STYLES_LV, lCX, "")
END IF
CASE %IDC_ORG_STYLES_BN
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN 'end prog
LoadStyles2ListView(CBHNDL, %IDC_AV_STYLES_LV)
s = TRIM$(gCcontrols(lCX).sStyles)
SelDefaultStyles ( CBHNDL, %IDC_AV_STYLES_LV, lCX, s )
END IF
CASE %IDC_SAVE_BN
IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN 'end prog
' copy changeable control texts back to global array
CONTROL GET TEXT CBHNDL, %IDC_TEXT_TB TO s
gCcontrols(lCX).sText = TRIM$(s)
'save styles from LV
s = ""
i = 0
DO
i = ListView_GetNextItem(hListView,i,%LVNI_SELECTED)
IF i = -1 THEN
squeezeTB2Text(CBHNDL, %IDC_STYLES_TB, s)
FUNCTION = 0
EXIT LOOP
END IF
Listview_GetItemText ( hListView, i, 0, sz, 1024)
IF s = "" THEN
s = sz
ELSE
s = s + ", " + sz
END IF
LOOP
gCcontrols(lCX).sStyles = s
'
CONTROL GET TEXT CBHNDL, %IDC_FONT_BN TO gCcontrols(lCX).sFont
CONTROL GET TEXT CBHNDL, %IDC_FONTATTS_LAB TO gCcontrols(lCX).sFontAtts
CONTROL GET TEXT CBHNDL, %IDC_FONTSIZE_LAB TO s
gCcontrols(lCX).lFontSize = VAL(s)
gCcontrols(lCX).lFGColour = lFGColour
gCcontrols(lCX).lBGColour = lBGColour
gCcontrols(lCX).hFont = hFont
' update CC control
IF Lcx > 0 THEN
CONTROL SET TEXT ghCCDialog, %IDC_CCID, TRIM$(gCcontrols(lCX).sText)
ReFont (ghCCDialog, %IDC_CCID, hFont, sFont, lFontSize, lbold, lItalic, lUnderline, lFGCOlour, lBGColour)
ELSE
DIALOG SET TEXT hparent, TRIM$(gCcontrols(lCX).sText)
deleteObject hfont
hFont = SDMakeFont(sFont, lfontsize, lbold, litalic, lunderline)
DIALOG SEND hParent, %WM_SETFONT, hFont, 0 ' parent dialog is the main one, not Ccontrols dialog!
DIALOG SET COLOR hParent, lfgcolour, lbgcolour
DIALOG REDRAW hParent
END IF
END IF
DIALOG END CBHNDL, 0
'
CASE %IDC_BGCOLOR_BN
IF (CBCTLMSG = %BN_CLICKED) THEN
s = SelColour(CBHNDL)
CONTROL SET TEXT CBHNDL, %IDC_BGCOLOR_BN, "background: #" + s
lbgcolour = VAL("&H" + s)
ReFont (CBHNDL, %IDC_TEXT_TB, hFont, sFont, lFontSize, lbold, lItalic, lUnderline, lFGCOlour, lBGColour)
END IF
'
CASE %IDC_FONT_BN
IF (CBCTLMSG = %BN_CLICKED) THEN
pCFS = ChooseQTPFont( CBHNDL)
IF pCFS = 0 THEN
FUNCTION = 1
EXIT FUNCTION
END IF
pLF = @pCFS.lplogfont
sfont = @pLF.lfFaceName
CONTROL SET TEXT CBHNDL, %IDC_FONT_BN, sfont
lFGColour = @pCFS.rgbcolors
lfontsize = @pCFS.ipointsize/10
CONTROL SET TEXT CBHNDL, %IDC_FONTSIZE_LAB, STR$(lfontsize)
s = ""
lbold = 0: lItalic = 0: lUnderLine = 0
litalic = @pLF.lfItalic
IF litalic <> 0 THEN
s = s + ", italic"
END IF
lUnderline = @pLF.lfUnderline
IF lUnderline <> 0 THEN s = s + ", underline"
IF @pLF.lfWeight > 699 THEN
s = s + ", bold"
lbold = %TRUE
END IF
'just ignoring strikeout.
IF LEFT$(s,1) = "," THEN s = MID$(s,3)
CONTROL SET TEXT CBHNDL, %IDC_FONTATTS_LAB, s
ReFont (CBHNDL, %IDC_TEXT_TB, hFont, sFont, lFontSize, lbold, lItalic, lUnderline, lFGCOlour, lBGColour)
END IF
END SELECT
END SELECT
END FUNCTION
'--------------------------------------------------------------------------------------------
FUNCTION ShowPROP(BYVAL hParent AS DWORD) AS LONG
LOCAL lRslt AS LONG
LOCAL hfont AS LONG
LOCAL hDlg AS DWORD
hFONT = GetStockObject(%SYSTEM_FIXED_FONT)
DIALOG NEW hParent, "Control Properties", 85, 0, 455, 260, %WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_SYSMENU OR _
%WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, %WS_EX_ACCEPTFILES _
OR %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
CONTROL ADD TEXTBOX, hDlg, %IDC_TEXT_TB, "", 60, 45, 160, 25,%ES_MULTILINE
CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "Dialog Id", 10, 5, 135, 10
CONTROL ADD LABEL, hDlg, %IDC_CTRL_NO_LAB, "Control Number", 10, 15, 135, 10
CONTROL ADD LABEL, hDlg, %IDC_CTRL_TYPE_LAB, "type of Control: ", 10, 25, 135, 10
CONTROL ADD LABEL, hDlg, %IDC_LABEL4, "Text", 10, 35, 50, 10
CONTROL ADD LABEL, hDlg, %IDC_LABEL3, "Font", 10, 70, 50, 10
CONTROL ADD BUTTON, hDlg, %IDC_FONT_BN, "", 60, 70, 106, 15
CONTROL ADD LABEL, hDlg, %IDC_LABEL21, "Font size", 10, 85, 50, 10
CONTROL ADD LABEL, hDlg, %IDC_LABEL22, "Font Attributes", 10, 95, 100, 10
CONTROL ADD LABEL, hDlg, %IDC_FONTSIZE_LAB, "", 60, 85, 20, 10,%ES_NUMBER
CONTROL ADD LABEL, hDlg, %IDC_FONTATTS_LAB, "", 60, 95, 160, 10
CONTROL ADD BUTTON, hDlg, %IDC_BGCOLOR_BN, "Background", 60, 110, 80, 10
CONTROL ADD LINE, hDlg, %IDC_LINE1, "Line1", 10, 150, 205, 70
CONTROL ADD LINE, hDlg, %IDC_LINE2, "Line2", 50, 165, 155, 45
CONTROL ADD LABEL, hDlg, %IDC_X_LAB, "X", 10, 175, 25, 10
CONTROL ADD LABEL, hDlg, %IDC_Y_LAB, "Y", 50, 150, 25, 10
CONTROL ADD LABEL, hDlg, %IDC_W_LAB, "W", 110, 165, 25, 10
CONTROL ADD LABEL, hDlg, %IDC_H_LAB, "H", 185, 185, 25, 10
CONTROL ADD BUTTON, hDlg, %IDC_SAVE_BN, "OK", 10, 225, 30, 10
CONTROL ADD BUTTON, hDlg, %IDC_DEF_STYLES_BN, "DEFAULT STYLES", 55, 225, 80, 10
CONTROL ADD BUTTON, hDlg, %IDC_ORG_STYLES_BN, "UNDO STYLES CHANGES", 55, 240, 90, 10
CONTROL ADD $WC_LISTVIEW, hDlg, %IDC_AV_STYLES_LV, "", 223, 25, 225, 220, _
%ws_child OR %WS_TABSTOP _
OR %WS_VISIBLE OR %LVS_SHOWSELALWAYS OR %LVS_REPORT, %WS_EX_CLIENTEDGE _
OR %LVS_EX_LABELTIP OR %LVS_EX_INFOTIP
DIALOG SHOW MODAL hDlg, CALL ShowPROPProc TO lRslt
FUNCTION = lRslt
END FUNCTION
'---------------------------------------------------------------------------------------------------
' get a list of styles & concoct the styles part of a DDT control or dialog specification from it
' seperating out regular and extended components
FUNCTION CCGetStylesList ( LCX AS LONG) AS STRING
LOCAL l AS LONG
LOCAL s, ss, sx AS STRING
' derive regular styles list for control
s = "" ' styles list
sx = "" ' extended styles list
FOR l = 1 TO PARSECOUNT(gCcontrols(lcx).sStyles)
ss = PARSE$(gCcontrols(lcx).sStyles, l)
IF ss <> "" THEN
IF ASC(MID$(ss,1)) <> 0 THEN ' as the source is a fixed length string inside a UDT, empty str can be all nulls.
IF INSTR(ss, "_EX_") = 0 THEN
s = s + " OR %" + TRIM$(PARSE$( gCcontrols(lcx).sStyles, l))
ELSE
sx = sx + " OR %" + TRIM$(PARSE$( gCcontrols(lcx).sStyles, l))
END IF
END IF
END IF
NEXT
s = MID$(s,5) ' get rid of leading 'OR '
sx = MID$(sx,5) ' get rid of leading 'OR '
FUNCTION = s + "," + sx
END FUNCTION
'------------------------------------------------------------------------------
' return a string of coordinates for the control whose index in cControls is passed in the parameter
FUNCTION CCgetCoords( lcx AS LONG) AS STRING
FUNCTION = STR$(gCControls(lcx).X) + "," _
+ STR$(gCControls(lcx).Y) + "," _
+ STR$(gCControls(lcx).W) + "," _
+ STR$(gCControls(lcx).H)
END FUNCTION
'-------------------------------------------------------------------------------------
' return the control id for the i'th CControl.
FUNCTION GetCtrlId ( i AS LONG ) AS STRING
FUNCTION = "CONTROLIDERROR!!"
SELECT CASE gCControls(i).lCtrlType
CASE %our_label_type, %our_textbox_type, %our_checkbox_type,%our_listbox_type,%our_button_type
FUNCTION = "%IDC_" + gsControlTypes(gCControls(i).lCtrlType) + TRIM$(STR$(1005 + i))
CASE %our_listview_type
FUNCTION = "%IDC_" + "LV" + TRIM$(STR$(1005 + i))
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
SUB OutPutSampleListView ( hfile AS LONG)
PRINT #hfile, "SUB SampleListView(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL lColCnt AS LONG, BYVAL lRowCnt AS LONG)
PRINT #hfile, " LOCAL lCol AS LONG
PRINT #hfile, " LOCAL lRow AS LONG
PRINT #hfile, " LOCAL hCtl AS DWORD
PRINT #hfile, " LOCAL tLVC AS LV_COLUMN
PRINT #hfile, " LOCAL tLVI AS LV_ITEM
PRINT #hfile, " LOCAL szBuf AS ASCIIZ * 32
PRINT #hfile, " LOCAL lStyle AS LONG
PRINT #hfile, " CONTROL HANDLE hDlg, lID TO hCtl
PRINT #hfile, " lStyle = ListView_GetExtendedListViewStyle(hCtl)
PRINT #hfile, " ListView_SetExtendedListViewStyle hCtl, lStyle OR %LVS_EX_FULLROWSELECT OR %LVS_EX_GRIDLINES
PRINT #hfile," ' Load column headers.
PRINT #hfile," tLVC.mask = %LVCF_FMT OR %LVCF_TEXT OR %LVCF_SUBITEM
PRINT #hfile," tLVC.fmt = %LVCFMT_LEFT
PRINT #hfile," tLVC.pszText = VARPTR(szBuf)
PRINT #hfile," FOR lCol = 0 TO lColCnt - 1
PRINT #hfile," szBuf = USING$(" + $DQ + "Column #" + $DQ + ", lCol)
PRINT #hfile," tLVC.iOrder = lCol
PRINT #hfile," ListView_InsertColumn hCtl, lCol, tLVC
PRINT #hfile," NEXT lCol
PRINT #hfile,"
PRINT #hfile," ' Load sample data.
PRINT #hfile," FOR lRow = 0 TO lRowCnt - 1
PRINT #hfile," tLVI.stateMask = %LVIS_FOCUSED
PRINT #hfile," tLVI.pszText = VARPTR(szBuf)
PRINT #hfile," tLVI.iItem = lRow
PRINT #hfile," FOR lCol = 0 TO lColCnt - 1
PRINT #hfile," szBuf = USING$(" + $DQ + "Column # Row #" + $DQ + ", lCol, lRow)
PRINT #hfile," tLVI.iSubItem = lCol
PRINT #hfile," tLVI.lParam = lRow
PRINT #hfile," IF lCol = 0 THEN
PRINT #hfile," tLVI.mask = %LVIF_TEXT OR %LVIF_PARAM OR %LVIF_STATE
PRINT #hfile," ListView_InsertItem hCtl, tLVI
PRINT #hfile," ELSE
PRINT #hfile," tLVI.mask = %LVIF_TEXT
PRINT #hfile," ListView_SetItem hCtl, tLVI
PRINT #hfile," END IF
PRINT #hfile," NEXT lCol
PRINT #hfile," NEXT lRow
PRINT #hfile,"
PRINT #hfile," ' Auto size columns.
PRINT #hfile," FOR lCol = 0 TO lColCnt - 2
PRINT #hfile," ListView_SetColumnWidth hCtl, lCol, %LVSCW_AUTOSIZE
PRINT #hfile," NEXT lCol
PRINT #hfile," ListView_SetColumnWidth hCtl, lColCnt - 1, %LVSCW_AUTOSIZE_USEHEADER
PRINT #hfile,"END SUB
END SUB
'------------------------------------------------------------------------------
SUB ExportPBSource (hD AS DWORD)
STATIC spath AS STRING
LOCAL buf AS STRING
LOCAL dwstyle AS DWORD
LOCAL hfile, lcx, i, l, x, y, w, h AS LONG
LOCAL s, sx, sfont, sdeclarefonts, sdeletefonts, smakefonts AS STRING
LOCAL lbold, litalic, lunderline AS LONG
'------------------------ get filename
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY
Buf = "unknown.bas"
' spath = gddlpath
IF SaveFileDialog(hD, "Save as:", g_app_name, sPath, "*.bas", "bas", _
%OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT) = 0 THEN
EXIT SUB
END IF
CHDIR spath
hfile = FREEFILE
OPEN g_app_name FOR OUTPUT AS hfile
' write header up to not inc ~PBFORMS END CONSTANTS
PRINT #hfile, "#PBFORMS CREATED V1.51
PRINT #hfile, "#COMPILE EXE
PRINT #hfile, "#DIM ALL
PRINT #hfile, ""
PRINT #hfile, "#PBFORMS BEGIN INCLUDES
' PRINT #hfile, "%USEMACROS = 1
PRINT #hfile, "#IF NOT %DEF(%WINAPI)
PRINT #hfile, " #INCLUDE ""WIN32API.INC""
PRINT #hfile, "#ENDIF
PRINT #hfile, "#INCLUDE ""PBForms.INC""
PRINT #hfile, "#PBFORMS END INCLUDES
PRINT #hfile, ""
PRINT #hfile, "#IF NOT %DEF(%COMMCTRL_INC)
PRINT #hfile, " #INCLUDE ""COMMCTRL.INC""
PRINT #hfile, "#ENDIF
' PRINT #hfile, "#INCLUDE ""comdlg32.inc""
PRINT #hfile, ""
PRINT #hfile, "#PBFORMS BEGIN CONSTANTS
PRINT #hfile, "%IDD_DIALOG1 = 101
' write constants
FOR lcx = 1 TO gCCX
IF gCControls(lcx).lCtrlType = %our_listview_type THEN
s = "%IDC_LV" + TRIM$(STR$(1005 + lcx)) + " = " + STR$(1005 + lcx)
ELSE
s = "%IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx)) + " = " + STR$(1005 + lcx)
END IF
PRINT #hfile, s
NEXT
' write body down to but not incl ~PBFORMS END DIALOG
PRINT #hfile, "#PBFORMS END CONSTANTS
PRINT #hfile, ""
PRINT #hfile, "'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
PRINT #hfile, "$DEFAULT_LV_FONTNAME = ""courier new""
PRINT #hfile, "%DEFAULT_LV_FONTSIZE = 10
PRINT #hfile, "%DEFAULT_LV_FONTITALICS = 0
PRINT #hfile, "%DEFAULT_LV_FONTBOLD = 0
PRINT #hfile, "%DEFAULT_LV_FONTUNDERLINE = 0
PRINT #hfile, "$Q = CHR$(34)
PRINT #hfile, "'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
PRINT #hfile, "'
PRINT #hfile, "GLOBAL scols AS STRING
PRINT #hfile, "GLOBAL hlv AS LONG ' listbox handle
PRINT #hfile, "DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
PRINT #hfile, "DECLARE sub SampleListView(BYVAL hDlg AS DWORD, BYVAL lID AS LONG, BYVAL _
PRINT #hfile, " lColCnt AS LONG, BYVAL lRowCnt AS LONG)
PRINT #hfile, "DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
PRINT #hfile, ""
PRINT #hfile, "#PBFORMS DECLARATIONS
PRINT #hfile, "FUNCTION PBMAIN()
PRINT #hfile, " 'DIM SCOLS(%MAX_COLUMNS_PER_TABLE) AS GLOBAL STRING
PRINT #hfile, " PBFormsInitComCtls (%ICC_WIN95_CLASSES OR %ICC_DATE_CLASSES OR _
PRINT #hfile, " %ICC_INTERNET_CLASSES)
PRINT #hfile, " ShowDIALOG1 %HWND_DESKTOP
PRINT #hfile, "END FUNCTION
OutputSampleListView(hfile)
PRINT #hfile, "FUNCTION AFontMake(BYVAL sFontName AS STRING, BYVAL nPointSize AS LONG, BYVAL bIsBold AS LONG, BYVAL bIsItalic AS LONG, BYVAL bIsUnderline AS LONG ) AS LONG
PRINT #hfile, " LOCAL hDC AS LONG, CyPixels AS LONG
PRINT #hfile, " hDC = GetDC(%HWND_DESKTOP)
PRINT #hfile, " CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
PRINT #hfile, " ReleaseDC %HWND_DESKTOP, hDC
PRINT #hfile, " nPointSize = (nPointSize * CyPixels) \ 72
PRINT #hfile, " FUNCTION = CreateFont(0 - nPointSize, 0, 0, 0, IIF&(bIsBold, %FW_BOLD, %FW_NORMAL), bIsItalic, bIsUnderline, 0, _
PRINT #hfile, " %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
PRINT #hfile, " %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY sFontName)
PRINT #hfile, "END FUNCTION
PRINT #hfile, "' ------------------------------------------------
PRINT #hfile, "CALLBACK FUNCTION ShowDIALOG1Proc()
PRINT #hfile, " STATIC rowrect AS RECT
PRINT #hfile, " STATIC hLV, lstyle AS LONG
PRINT #hfile, " LOCAL pnmh AS NMHDR PTR
PRINT #hfile, " LOCAL pnm AS NMLVCUSTOMDRAW PTR
PRINT #hfile, " LOCAL lpLVDispInfo AS LV_DISPINFO PTR
PRINT #hfile, " LOCAL szString AS ASCIIZ * 256
PRINT #hfile, " SELECT CASE AS LONG CBMSG
PRINT #hfile, " CASE %WM_INITDIALOG
PRINT #hfile, " ' Initialization handler
PRINT #hfile, " CASE %WM_NCACTIVATE
PRINT #hfile, " STATIC hWndSaveFocus AS DWORD
PRINT #hfile, " IF ISFALSE CBWPARAM THEN
PRINT #hfile, " ' Save control focus
PRINT #hfile, " hWndSaveFocus = GetFocus()
PRINT #hfile, " ELSEIF hWndSaveFocus THEN
PRINT #hfile, " ' Restore control focus
PRINT #hfile, " SetFocus(hWndSaveFocus)
PRINT #hfile, " hWndSaveFocus = 0
PRINT #hfile, " END IF
PRINT #hfile, " CASE %WM_COMMAND
PRINT #hfile, " SELECT CASE AS LONG CBCTL
' insert button catchers here
FOR lcx = 1 TO gCCX
IF gCcontrols(lcx).lCtrlType = %our_button_type THEN
PRINT #hfile, " case %IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx))
PRINT #hfile, " IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
PRINT #hfile, " ? " + $DQ + "it's %IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx)) + $DQ
PRINT #hfile, " end if
END IF
NEXT
PRINT #hfile, " END SELECT
PRINT #hfile, " END SELECT
PRINT #hfile, "END FUNCTION
PRINT #hfile, "FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
PRINT #hfile, " LOCAL lRslt AS LONG
PRINT #hfile, ""
PRINT #hfile, "#PBFORMS BEGIN DIALOG %IDD_DIALOG1->->
PRINT #hfile, " LOCAL hDlg AS DWORD
PRINT #hfile, ""
' font stuff
' make up a block of code for declaring font handles, deleting fonts, and making fonts/send to controls
FOR lcx = 1 TO gCCX
sfont = gCControls(lcx).sFont
IF (sfont <> "") AND (LEFT$(sfont,1) = CHR$(0)) THEN sfont = "" ' in case sfont is an uninitialised string of nulls
IF (TRIM$(gCControls(lcx).sFont) <> "") OR (TRIM$(gCControls(lcx).sFontAtts) <> "") OR (gCControls(lcx).lFontsize <> 0) THEN
sDeclareFonts = sDeclareFonts + " local hfont" + TRIM$(STR$(lcx)) + " as long" + $CRLF
sdeletefonts = sdeletefonts + "Deleteobject " + "hfont" + TRIM$(STR$(lcx)) + $CRLF
s = TRIM$(gCcontrols(lCX).sFontAtts)
lunderline= %FALSE: litalic = %FALSE: lbold = %FALSE
IF INSTR(s, "bold") THEN lbold = %TRUE
IF INSTR(s, "italic") THEN litalic = %TRUE
IF INSTR(s, "underline") THEN lunderline = %TRUE
smakefonts = smakefonts + " hfont" + TRIM$(STR$(lcx)) _
+ " = Afontmake (" + $DQ + TRIM$(gCControls(lcx).sFont) + $DQ + "," _
+ STR$(gCControls(lcx).lFontSize) + "," _
+ STR$(lbold) + "," _
+ STR$(litalic) + "," _
+ STR$(lunderline) + ")" _
+ $CRLF _
+ " CONTROL SEND hdlg, " + getCtrlId(lcx) _
+ ", %WM_SETFONT, hfont" + TRIM$(STR$(lcx)) + ", 0" + $CRLF
END IF
NEXT
' declare LONGs for font handles
PRINT #hfile, sdeclarefonts
' get coordinates of dialog
DIALOG GET LOC ghMainDD TO x, y
DIALOG GET SIZE ghmainDD TO w, h
s = STR$(x) + "," + STR$(y) + "," + STR$(w) + "," + STR$(h) + ","
PRINT #hfile, " DIALOG NEW hParent" + "," + $DQ + TRIM$(gCControls(0).sText) + $DQ + "," + s;
PRINT #hfile, " " + CCGetStylesList(0) + ", to hdlg "
' write CONTROL ADD statements for each Ccontrol
FOR lcx = 1 TO gCCX
SELECT CASE gCControls(lcx).lCtrlType
CASE %our_label_type, %our_textbox_type, %our_checkbox_type, %our_button_type
PRINT #hfile, " CONTROL ADD " + gsControlTypes(gCControls(lcx).lCtrlType)+",hDlg,";
PRINT #hfile, "%IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx)) + ",";
PRINT #hfile, $DQ + TRIM$(gCControls(lcx).sText) + $DQ+ ",";
PRINT #hfile, CCgetCoords(lcx) + "," + CCgetStylesList(lcx)
PRINT #hfile, " control set color hdlg,%IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx)) + ",";
PRINT # hfile, STR$(gCControls(lcx).lFGcolour) + "," + STR$(gCControls(lcx).lBGcolour)
CASE %our_listbox_type
PRINT #hfile, " CONTROL ADD LISTBOX,hDlg,";
PRINT #hfile, "%IDC_" + gsControlTypes(gCControls(lcx).lCtrlType) + TRIM$(STR$(1005 + lcx)) + ",,";
PRINT #hfile, CCgetCoords(lcx) + "," + CCgetStylesList(lcx)
CASE %our_listview_type
PRINT #hfile, " CONTROL ADD $WC_LISTVIEW, hDlg,";
PRINT #hfile, "%IDC_LV" + TRIM$(STR$(1005 + lcx)) + ",";
PRINT #hfile, $DQ + $DQ + "," + CCgetCoords(lcx) + "," + CCgetStylesList(lcx)
PRINT #hfile, " SampleListView ( hDlg, %IDC_LV" + TRIM$(STR$(1005 + lcx)) + ", 10, 10)"
END SELECT
NEXT
' make fonts & send to controls
PRINT #hfile, smakefonts
' write remainder of file
PRINT #hfile, "#PBFORMS END DIALOG
PRINT #hfile, ""
PRINT #hfile, " DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
PRINT #hfile, ""
PRINT #hfile, "#PBFORMS BEGIN CLEANUP %IDD_DIALOG1
PRINT #hfile, ""
PRINT #hfile, sdeletefonts
PRINT #hfile, "#PBFORMS END CLEANUP
PRINT #hfile, ""
PRINT #hfile, " FUNCTION = lRslt
PRINT #hfile, "END FUNCTION
CLOSE hfile
END SUB
'------------------------------------------------------------------------------
SUB SaveCCs ( hD AS DWORD, sfile AS STRING)
LOCAL hfile, l AS LONG
LOCAL dwstyle AS DWORD
LOCAL spath AS STRING
GLOBAL gCcontrols() AS CPH
' store grid dimensions to 0'th element of array
gCcontrols(0).lGridX = gGridSizeX
gCcontrols(0).lGridY = gGridSizeY
gCcontrols(0).ncontrols = gCCX
IF sfile <> "" THEN
g_app_name = sfile
END IF
'------------------------ get filename
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY
' Buf = "unknown.ftf"
IF SaveFileDialog(hD, "Save as:", g_app_name, sPath, "*.ftf", "ftf", _
%OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT) = 0 THEN
EXIT SUB
END IF
CHDIR spath
TRY
KILL g_app_name
CATCH
END TRY
' save dialog coordinates
DIALOG GET LOC ghMainDD TO gCcontrols(0).x, gCcontrols(0).y
DIALOG GET SIZE ghmainDD TO gCcontrols(0).w, gCcontrols(0).h
hfile = FREEFILE
OPEN g_APP_NAME FOR BINARY AS #hfile
PUT #hfile, 1, gCcontrols()
CLOSE #hfile
g_app_name = ""
END SUB
'----------------------------------------------------------------------
' load a control to the main dialog window from the gCcontrol array
' NB control number zero is the main dialog itself, so this sub doesn't expect it!
SUB LoadControl ( lcx AS LONG )
LOCAL s, sfont AS STRING
LOCAL sTXT AS STRING
LOCAL hD AS DWORD
LOCAL lbold, leventcount, litalic, lunderline AS LONG
IF gCcontrols(lcx).hD = 0 THEN EXIT SUB ' that control has been deleted before save
DIALOG NEW ghMainDD, "", gCcontrols(lcx).X, gCcontrols(lcx).Y, gCcontrols(lcx).W, gCcontrols(lcx).H, _
%WS_POPUP OR %WS_THICKFRAME OR %WS_CHILD OR _
%WS_CLIPSIBLINGS OR %WS_VISIBLE OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
%DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_TOOLWINDOW OR _
%WS_EX_TOPMOST OR %WS_EX_LEFT OR %WS_EX_LTRREADING TO hD
SELECT CASE gCcontrols(lcx).lCtrlType
CASE %our_button_type
CONTROL ADD BUTTON, hD, %IDC_CCID, "", 0,0,0,0,%BS_FLAT
CASE %our_checkbox_type
CONTROL ADD CHECKBOX, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_label_type
CONTROL ADD LABEL, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_textbox_type
CONTROL ADD TEXTBOX, hD, %IDC_CCID, "", 0,0,0,0
CASE %our_listbox_type
CONTROL ADD LISTBOX, hD, %IDC_CCID, , 0,0,0,0
DummyListBox ( hD, %IDC_CCID, 10)
CASE %our_listview_type
CONTROL ADD "SysListView32", hD, %IDC_CCID, "", 0,0,0,0, _
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %LVS_REPORT OR _
%LVS_SHOWSELALWAYS, %WS_EX_LEFT OR %WS_EX_CLIENTEDGE OR _
%WS_EX_RIGHTSCROLLBAR
SampleListView ( hD, %IDC_CCID, 10, 10)
END SELECT
sfont = gCControls(lcx).sFont
IF (sfont <> "") AND (LEFT$(sfont,1) = CHR$(0)) THEN sfont = "" ' in case sfont is an uninitialised string of nulls
IF (TRIM$(gCControls(lcx).sFont) <> "") OR (TRIM$(gCControls(lcx).sFontAtts) <> "") OR (gCControls(lcx).lFontsize <> 0) THEN
s = TRIM$(gCcontrols(lCX).sFontAtts)
lunderline= %FALSE: litalic = %FALSE: lbold = %FALSE
IF INSTR(s, "bold") THEN lbold = %TRUE
IF INSTR(s, "italic") THEN litalic = %TRUE
IF INSTR(s, "underline") THEN lunderline = %TRUE
gCcontrols(lcx).hfont = SDMakeFont (TRIM$(gCControls(lcx).sFont),gCControls(lcx).lFontSize, _
lbold, litalic, lunderline)
CONTROL SEND hD, %IDC_CCID, %WM_SETFONT, gCcontrols(lcx).hfont, 0
END IF
CONTROL SET COLOR hD, %IDC_CCID, gCcontrols(lcx).lFGColour, gCcontrols(lcx).lBGColour
CONTROL SET TEXT hD, %IDC_CCID, TRIM$(gCcontrols(lcx).sText)
CONTROL SET LOC hD, %IDC_CCID, 0, 0
gCcontrols(lcx).hD = hD ' replace the dialog handle used on the previous session with the current one
DIALOG SHOW MODELESS hD, CALL CC_dialogProc 'TO lRslt
END SUB
'------------------------------------------------------------------------------
SUB LoadCCs (hd AS DWORD)
LOCAL i, hfile, l, x, y AS LONG
LOCAL dwstyle AS DWORD
LOCAL buf AS STRING
LOCAL spath AS STRING
GLOBAL gCcontrols() AS CPH
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY
buf = "FTF files (*.FTF)|*.FTF|"
IF OpenFileDialog (hD, "Locate FTF file ", g_APP_NAME, spath, buf, "FTF", dwstyle) = 0 THEN
EXIT SUB
END IF
' delete any ccontrols as they will otherwise be orphaned
FOR i = 1 TO gCCX
IF gCcontrols(i).hFont <> 0 THEN
deleteobject gCcontrols(i).hFont
gCcontrols(i).hFont = 0
END IF
DIALOG SEND gCcontrols(i).hD, %WM_SYSCOMMAND, %SC_CLOSE, 0
' DIALOG END gCcontrols(i).hD, 0
gCcontrols(i).hD = 0
NEXT i
'
hfile = FREEFILE
OPEN g_APP_NAME FOR BINARY AS #hfile
GET #hfile, 1, gCcontrols() TO l
CLOSE #hfile
g_app_name = ""
gCCX = gCcontrols(0).ncontrols
x = gCcontrols(0).X
y = gCcontrols(0).Y
' adjust main dialog
DIALOG SET LOC hD, gCcontrols(0).X, gCcontrols(0).Y
DIALOG SET SIZE hD, gCcontrols(0).W, gCcontrols(0).H
DIALOG SET TEXT hd, TRIM$(gCcontrols(0).sText)
gGridSizeX = gCcontrols(0).lGridX
gGridSizeY = gCcontrols(0).lGridY
CONTROL SET TEXT ghMenuDialog, %IDC_GridX_tb, TRIM$(STR$( gGridSizeX))
CONTROL SET TEXT ghMenuDialog, %IDC_GridY_tb, TRIM$(STR$( gGridSizeY))
FOR i = 1 TO l
' draw controls from array
LoadControl(i)
NEXT
END SUB
'------------------------------------------------------------------------------
Comment