program xtra15,1.0(104) ! xtree property sheet example[100] ! Program Name: xtra15 ! Description: XTREE-based property sheet example ! (requires 5.1.1202+) ! Author: Jack McGregor ! Date: 11-Jan-2011 !--------------------------------------------------------------------- !Notes: ! We'll use the property sheet to display and edit a set of ! attributes, some representing some hypothetical report selection ! parameters, and some affecting the format of the property sheet ! itself. (Changes to the latter category are detected immediately ! and the tree recreated. For the others, there are a mixture of ! validation types.) ! ! This program is designed to be simple to follow, rather than ! to be a good example of design. (For example, it leans toward ! an in-line style, rather than modularization.) ! !-------------------------------------------------------------------- !Edit History ![100] January 11, 2011 03:03 PM Edited by joaquin ! Created ![101] January 25, 2011 03:24 PM Edited by jack ! Add DefaultFont, _ (shrink edit width based on allowed chars); ! set xtr.closedended and add XTF2_AUTOEXPCOL ![102] January 26, 2011 07:56 AM Edited by jack ! Add multilevel, nostrip ![103] January 31, 2011 02:52 PM Edited by jack ! Use Dspwid to illustrate alternate method of setting edit box width. ![104] fevrier 06, 2011 11:38 PM Edited by jack ! Add tooltips, ParentID= in COLDEF /jdm !--------------------------------------------------------------------- !{end history} ++pragma ERROR_IF_NOT_MAPPED "TRUE" ++include ashinc:ashell.def ++include ashinc:xtree.def ++include ashinc:xtree.sdf ! Define a structure to contain all of the items/columns of the tree. ! Notes: ! 1. The layout of the structure must match the coldef layout (and typically ! the data layout as well, although that isn't strictly necessary). ! 2. The structure can contain elements which don't figure in the coldef ! (this might be useful if adapting some existing record structure for ! which you want to edit only certain fields.) ! 3. If using a single structure for both the data and answer parameters, ! remember to set the XTF2_ANSEQDATA flag! ! 4. Fields that contain control bytes (like the color byte for B columns, ! or the celllist identifier for s columns) can be mapped to separate ! fields to simplify the parsing (see the sort'listid field below ! for an example.) DEFSTRUCT ST_REC ! structure containing report config params map2 xtree'params ! params affecting this XTREE itself map3 xheader1,s,1 ! dummy field to act as a section label map3 xtf'vary,s,1 ! XTF_VARY map3 xtr'itemlines,s,1 ! XTR'ITEMLINES map2 report'params ! params for a hypothetical report selection map3 xheader2,s,1 ! dummy field to act as a section label map3 seldesc,s,60 ! string describing selection map3 scust,s,11 ! starting customer # map3 ecust,s,11 ! ending customer # map3 sdate,s,10 ! start date (mm/dd/yyyy) map3 edate,s,10 ! end date (mm/dd/yyyy) map3 sortby(2) map4 sort'listid,s,1 ! reserved for celllist idx map4 sort'fldname,s,15 ! actual field name map3 subtotals,s,1 ! 0/1 map3 junk,s,80 ! (test if this matters) ENDSTRUCT define VALIDATE_OK = 0 define VALIDATE_REENTER = 1 define VALIDATE_RECREATE = -1 define MAX_FNAMES = 10 map1 fnames$(MAX_FNAMES),s,15 ! field names (for sort'fldname fields) fnames$(1) = "CustNum" fnames$(2) = "TrxNum" fnames$(3) = "TrxDate" fnames$(4) = "SubTotal" fnames$(5) = "Tax" fnames$(6) = "Total" fnames$(7) = "Terms" fnames$(8) = "PO" fnames$(9) = "ShipMethod" fnames$(10)= "Salesman" map1 rec,ST_REC ! instance of structure for editing map1 rec'orig,ST_REC ! copy of original (for cancel) map1 xtree'params map2 xt'maxcnt,f,6,1 ! must be 1 for property sheet mode map2 xtf,ST_XFLAGS ! ST_XFLAGS defined in xtree.sdf map2 xtr,XTRCTL ! XTRCTL defined in xtree.sdf map2 xtrcfg'chg,b,1,0 ! set when we need to reconfigure tree map1 xt'coldef$,s,0 map1 misc map2 x,F map2 y,F map2 ch,F,6,9 map2 i,F map2 dlg'rows,B,2,10 map2 dlg'cols,B,2,30 map2 dlg'srow,B,2,4 map2 dlg'scol,B,2,4 map2 dlg'id,B,2 map2 dlg'id$,s,10,"dlg1" ! [104] map2 dlg'title$,S,40,"XTREE Property Sheet Demo" map2 ok'id,B,2 map2 color'id,B,2 map2 cancel'id,B,2 map2 cstatus,F map2 exitcode,F map2 done,b,1 map2 vstatus,i,2 map2 mlvl,b,1 ! [102] map2 nostrip,b,1 ! [102] map2 lvl1$,s,1 ! [102] map2 nostrip$,s,1 ! [102] !{End map zone} ? tab(-1,0);"XTRA15 - Using XTREE as a 'Property Sheet' (aka Vertical Mode)" input "Multi-level (1/0) [0]: ",mlvl ! [102] if mlvl then ! [102] lvl1$ = "@" ! [102] input "Expand level [0]: ",xtr.EXPANDLEVEL ! [102] endif input "No strip (1/0) [0]: ",nostrip ! [102] if nostrip then nostrip$ = " " ! [102] input "Closed ended? (1/0) [0]: ",xtr.CLOSEDENDED ! [102] ! create a dialog... dlg'id = Fn'Create'Dialog(dlg'title$, dlg'srow, dlg'scol, dlg'rows, dlg'cols) ! setup the tree parameters xtf.FLAGS = 0 xtf.FLAGS2 = 0 ! these are mandatory for this program... xtf.FLAGS = xtf.FLAGS or XTF_XYXY ! alt coords (srow,scol,erow,ecol) xtf.FLAGS = xtf.FLAGS or XTF_COLDFX ! complex syntax in COLDEF xtf.FLAGS = xtf.FLAGS or XTF_EDITABLE ! needed for editable cb or text xtf.FLAGS = xtf.FLAGS or XTF_MODELESS ! Leave box on screen after exit xtf.FLAGS = xtf.FLAGS or XTF_FKEY ! Allow Fx codes!! xtf.FLAGS2 = xtf.FLAGS2 or XTF2_PROPSHEET ! Property Sheet mode xtf.FLAGS2 = xtf.FLAGS2 or XTF2_ANSEQDATA ! Answer array and data are same layout xtf.FLAGS2 = xtf.FLAGS2 or XTF2_AUTOEXPCOL ! [101] (goes with xtr.CLOSEDENDED) ! set up coldef (to match ST_REC structure) xt'coldef$ = "" ! define a list to use for sort field names xt'coldef$ = xt'coldef$ + "0~0~x~H~CellList=a" for i = 1 to MAX_FNAMES xt'coldef$ = xt'coldef$ + "," + fnames$(i) next i xt'coldef$ = xt'coldef$ + "~" ! define some colors to be used in cell color references xt'coldef$ = xt'coldef$ + "RGBbg=128,128,255,A~RGBbg=128,255,128,B~" xt'coldef$ = xt'coldef$ + "DefaultFont=Lucida Console~" ! [101] xt'coldef$ = xt'coldef$ + "ParentID="+dlg'id$+"~~" ! [104] xt'coldef$ = xt'coldef$ + "1~1~XTREE Parameters~SB~~" xt'coldef$ = xt'coldef$ + "2~1~XTF_VARY~TX"+lvl1$+"~ToolTip=Variable Height Rows~~" ![104] xt'coldef$ = xt'coldef$ + "3~1~Itemlines~#EX"+lvl1$+"~ToolTip=Max (or fixed) height of items~~" ![104] xt'coldef$ = xt'coldef$ + "4~1~Report Parameters~SB~~" xt'coldef$ = xt'coldef$ + "5~60~Selection Description~SEX_<"+lvl1$+"~Tooltip=Sample tooltip~~" ! [101] xt'coldef$ = xt'coldef$ + "65~11~Starting Customer #~#Ex<" & +lvl1$+nostrip$+"~Mask=###########~ToolTip=First customer to include~~" ![101][102] xt'coldef$ = xt'coldef$ + "76~11~Ending Customer #~#Ex_<" & +lvl1$+nostrip$+"~Mask=###########~Dspwid=6~ToolTip=Must be > starting customer #~~" ![101][103] xt'coldef$ = xt'coldef$ + "87~10~Starting Date~DE"+lvl1$+"~InfDef=DO~Format=MM/dd/yyyy~ToolTip=Enter starting trx date~~" xt'coldef$ = xt'coldef$ + "97~10~Ending Date~DE"+lvl1$+"~Format=MM/dd/yyyy~~" xt'coldef$ = xt'coldef$ + "107~16~Sort By (Primary)~SlsEX<"+lvl1$+"~~" xt'coldef$ = xt'coldef$ + "123~16~Sort By (Secondary)~SlsEX<"+lvl1$+"~~" xt'coldef$ = xt'coldef$ + "139~1~SubTotals~TX"+lvl1$+"~~" ! define some symbol names to help identify the columns by number (slightly ! inelegant in that you have to manually set them up and make sure they are right, ! but after that, it makes for more readable code) ! (note: column # isn't editable in this example) define XCOL_VARY = 2 define XCOL_ITEMLINES = 3 ! (column 4 isn't editable either) define XCOL_DESCRIPTION = 5 define XCOL_SCUST = 6 define XCOL_ECUST = 7 define XCOL_SDATE = 8 define XCOL_EDATE = 9 define XCOL_SORT1 = 10 define XCOL_SORT2 = 11 define XCOL_SUBTOTALS = 12 define XCOL_LASTCOL = 12 ! setup XTRCTL xtr.OPCODE = XTROP_CREATE xtr.CTLNO = -1 ! auto-select xtree # xtr.ITEMLINES = 1 xtr.SHOWGRID = 1 ! grid lines (yes) xtr.GRIDSTYLE = 2 ! solid horz & vert xtr.TRUNCATED = 1 ! show dots if truncated xtr.SELECTAREA = XTRSEL_AREA_CELL1 + XTRSEL_STY_CELL1 xtr.FLYBY = 1 ! Fly by highlighting (0=no, 1=yes) xtr.SCROLLTIPS = 1 ! Show scroll tips (0=no, 1=yes) xtr.KBDSTR = "VK_xF3" ! kbd click string xtr.USETHEMES = 1 ! 1=use XP themes (if available) ![104] xtr.PARENTID = dlg'id ! ID of parent control xtr.PARENTID = 0 ! [104] use Coldef ParentID=dlg1 ![102] xtr.CLOSEDENDED = 1 ! last col closed ended [101] ![102] xtr.EXPANDLEVEL = 2 ! [102] expand all xtr.MISCFLAGS = XTMF_TRUNCATED or XTMF_INTHEIGHT ! init data to some arbitrary values just for testing rec = fill$(" ",sizeof(rec)) rec.xtf'vary = "0" rec.xtr'itemlines = "1" rec.xheader1 = "A" ! specify a bg color rec.xheader2 = "B" ! specify a bg color rec.seldesc = "This is the description" rec.scust = "1111" rec.ecust = "" rec.sdate = "01/01/2000" rec.edate = "12/31/2012" rec.subtotals = "1" rec.sort'listid(1) = "a" ! match to CellList=a,... rec.sort'listid(2) = "a" ! make a copy of the data to restore in the cancel case rec'orig = rec !-------------------------------------------------------------- ! main loop - keeps calling XTREE until we exit with F2 or ESC !-------------------------------------------------------------- do xcall XTREE,2,3,rec,rec,xt'maxcnt,xt'coldef$, & exitcode,dlg'rows-2,dlg'cols-3,xtf,"",0,xtr TRACE.PRINT "$# $T Exitcode returned from XTREE: "+exitcode +", xrow,xcol="+xtr.XROW+","+xtr.XCOL switch exitcode case 1 ! ESC rec = rec'orig call Trace'Values(rec,"$# $T ESC (Cancel) - Restore original values:") done = 1 exit default ! field validation (-48), OK, etc vstatus = Fn'Validate(exitcode,rec,xtr) if (vstatus = VALIDATE_RECREATE) then ! we need to recreate tree ! (this is an unusual case, but since this tree edits ! information about its own cfg, sometimes we need to recreate) TRACE.PRINT "$# $T Deleting tree..." xtr.OPCODE = XTROP_DELETE xcall XTREE,2,3,rec,rec,xt'maxcnt,xt'coldef$, & exitcode,dlg'rows-2,dlg'cols-3,xtf,"",0,xtr TRACE.PRINT "$# $T Recreating tree..." ! adjust our tree cfg params to match the associated data field if rec.xtf'vary = 1 then xtf.FLAGS = xtf.FLAGS or XTF_VARY else xtf.FLAGS = xtf.FLAGS and not XTF_VARY endif xtr.ITEMLINES = rec.xtr'itemlines xtr.OPCODE = XTROP_CREATE elseif (vstatus = VALIDATE_REENTER or exitcode = -48) then xtr.OPCODE = XTROP_RESELECT else ! OK and no validation errors done = 1 call Trace'Values(rec,"$# $T Output Values:") endif exit endswitch loop until done ! close the dialog ! [save] button xcall AUI, AUI_CONTROL, CTLOP_DEL, dlg'id$ ! [104] !{Exit Program} END !{ErrorTrap} TRAP: END !{PROCEDURES} !--------------------------------------------------------------------------- ! Function Fn'Validate() ! Validate one or all fields ! Params ! exitcode [f6] (in) exitcode returned from XTREE ! (if -48, we can just validate the one field; else ! we may want to do them all) ! rec (ST_REC) (in/out) structure containing current state of data ! xtr [XTRCTL] (in/out) XTRCTL structure used by XTREE (the XROW/XCOL ! and TARGETROW/TARGETCOL fields are of most interest) ! Returns ! VALIDATE_OK (0) if there are no validation errors ! VALIDATE_REENTER (1) we need to reenter (to fix validation issues) ! VALIDATE_RECREATE (-1) need to totally recreate tree (this is an ! unusual case, used here because some of the fields ! in the tree actually affect the tree configuration) !--------------------------------------------------------------------------- FUNCTION Fn'Validate(exitcode as f6, rec as ST_REC, xtr as XTRCTL) as i2 map1 locals map2 col'first,i,2 ! starting column to validate map2 col'last,i,2 ! ending column to validate map2 col,i,2 ! working column map2 temp$,s,20 map2 status,f map2 days,f if exitcode = -48 then col'first = xtr.XCOL col'last = col'first else col'first = 1 col'last = XCOL_LASTCOL endif for col = col'first to col'last switch col case XCOL_VARY ! this column is set for conditional validation, so if exitcode = -48, ! that means we changed it, and because that affects the tree configuration ! itself, we'll return the RECREATE flag if (exitcode = -48) then Fn'Validate = VALIDATE_RECREATE if val(rec.xtf'vary) # 0 then TRACE.PRINT "$# $T (Setting XTF_VARY flag)" else TRACE.PRINT "$# $T (Clearing XTF_VARY flag)" endif else ! (for record validation, nothing to worry about here) endif exit case XCOL_ITEMLINES ! same idea as for XCOL_VARY if (exitcode = -48) then Fn'Validate = VALIDATE_RECREATE TRACE.PRINT "$# $T (Changing xtr.ITEMLINES to "+rec.xtr'itemlines+")" endif exit case XCOL_DESCRIPTION exit case XCOL_SCUST TRACE.PRINT "$# $T Validating starting customer ["+rec.scust+"]" if (val(rec.scust) # 0) and (val(rec.ecust) = 0) then xtr.TARGETCOL = XCOL_ECUST ! force user to ecustomer cell rec.ecust = rec.scust ! default ecust to scust TRACE.PRINT "$# $T Defaulting ending customer # to starting customer #"+rec.scust Fn'Validate = VALIDATE_REENTER endif exit case XCOL_ECUST TRACE.PRINT "$# $T Validating ending customer ["+rec.ecust+"]" if (val(rec.ecust) < val(rec.scust)) then xcall MSGBOX,"Ending customer must be >= starting customer","Data entry error", & MBTN_OK,MBICON_STOP,MBMISC_TASKMODAL xtr.TARGETCOL = XCOL_ECUST ! force user back to ecust cell TRACE.PRINT "$# $T Forcing user back to ending customer cell" Fn'Validate = VALIDATE_REENTER endif exit case XCOL_SDATE exit case XCOL_EDATE if (rec.sdate # "" and rec.edate # "") then ! both dates are valid dates xcall DATES,3,status,rec.edate,rec.sdate,days TRACE.PRINT "$# $T edate is "+days+" days after sdate" if days < 0 then xcall MSGBOX,"Ending date must be either blank or >= starting date","Data entry error", & MBTN_OK,MBICON_STOP,MBMISC_TASKMODAL xtr.TARGETCOL = XCOL_EDATE ! force reentry at ending date cell Fn'Validate = VALIDATE_REENTER endif endif case XCOL_SORT1 case XCOL_SORT2 ! if sort1 empty but sort2 not, reverse them if (rec.sort'fldname(1) = "" and rec.sort'fldname(2) # "") then temp$ = rec.sort'fldname(2) rec.sort'fldname(2) = rec.sort'fldname(1) rec.sort'fldname(1) = temp$ TRACE.PRINT "$# $T Swapping sort field 1 and field 2" xtr.TARGETCOL = XCOL_SORT2 ! reenter at sort field 2 endif exit case XCOL_SUBTOTALS exit endswitch ! quit validating after first error if Fn'Validate = VALIDATE_REENTER then exit endif next col xputarg 2,rec ! return updated rec (values) xputarg 3,xtr ! return updated XTRCTL fields ENDFUNCTION !--------------------------------------------------------------------------- ! Procedure Trace'Values() ! Display the current values in the debug message window ! Params ! rec [ST_REC] (in) structure containing values ! hdr$ [s0] (in) header message !--------------------------------------------------------------------------- PROCEDURE Trace'Values(rec as ST_REC, hdr$ as s0) TRACE.PRINT hdr$ TRACE.PRINT " vary =["+rec.xtf'vary+"]" TRACE.PRINT " itemlines=["+rec.xtr'itemlines+"]" TRACE.PRINT " seldesc =["+rec.seldesc+"]" TRACE.PRINT " scust =["+rec.scust+"]" TRACE.PRINT " ecust =["+rec.ecust+"]" TRACE.PRINT " sdate =["+rec.sdate+"]" TRACE.PRINT " edate =["+rec.edate+"]" TRACE.PRINT " sortfld1 =["+rec.sort'fldname(1)+"]" TRACE.PRINT " sortfld2 =["+rec.sort'fldname(2)+"]" TRACE.PRINT " subotals =["+rec.subtotals+"]" END PROCEDURE !--------------------------------------------------------------------------- ! Procedure Create'Dialog() ! Create a dialog to hold the XTREE ! Params ! title$ [s0] (in) dialog title ! srow,scol,rows,cols [b2] (in) upper left corner and size ! Returns ! numeric dialog id ! Notes: ! Dialog has following buttons: ! OK (xF2) ! CANCEL (ESC) !--------------------------------------------------------------------------- FUNCTION Fn'Create'Dialog(title$ as s0, & srow as b2, scol as b2, rows as b2, cols as b2) map1 locals map2 erow,b,2 map2 ecol,b,2 map2 dlgid,b,2 map2 dlgid$,s,10,"dlg1" ! [104] erow = srow + rows - 1 ecol = scol + cols - 1 ! create a dialog xcall AUI, AUI_CONTROL, CTLOP_ADD, dlgid$, title$, MBST_ENABLE, & MBF_DIALOG+MBF_ALTPOS+MBF_SYSMENU, NUL_CMD$, NUL_FUNC$, dlgid, & srow, scol, erow, ecol, & NUL_FGC, NUL_BGC, NUL_FONTATTR, NUL_FONTSCALE, NUL_FONTFACE$, & NUL_TOOLTIP$, NUL_PARENTID, NUL_WINCLASS$, NUL_WINSTYLE, & NUL_WINSTYLEX ! [ok] button xcall AUI, AUI_CONTROL, CTLOP_ADD, "btnOK", "&OK", MBST_ENABLE, & MBF_BUTTON+MBF_KBD, "VK_xF2", NUL_FUNC$, NUL_CSTATUS, & rows-1, cols-24, rows, cols-19, & NUL_FGC, NUL_BGC, NUL_FONTATTR, NUL_FONTSCALE, NUL_FONTFACE$, & "Save and Exit", dlgid$, NUL_WINCLASS$, NUL_WINSTYLE, & NUL_WINSTYLEX ! [cancel] button xcall AUI, AUI_CONTROL, CTLOP_ADD, "btnCancel", "&Cancel", MBST_ENABLE, & MBF_BUTTON+MBF_KBD, "VK_ESC", NUL_FUNC$, NUL_CSTATUS, & rows-1, cols-10, rows, cols-5, & NUL_FGC, NUL_BGC, NUL_FONTATTR, NUL_FONTSCALE, NUL_FONTFACE$, & "Quit without Saving", dlgid$, NUL_WINCLASS$, NUL_WINSTYLE, & NUL_WINSTYLEX Fn'Create'Dialog = dlgid END FUNCTION