Liren Large Software Subsidy 5

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 5 / 05.iso / a / a106 / 2.ddi / APPSCX.PR_ / APPSCX.bin

Wrap

Text File | 1994-04-28 | 101.3 KB | 3,093 lines

* ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ 02/23/93 APPSCX.SPR 11:31:10 ║ * ║ ║ * ╟─────────────────────────────────────────────────────────╢ * ║ ║ * ║ Walter J. Kennamer ║ * ║ ║ * ║ Copyright (c) 1993 Microsoft Corp. ║ * ║ One Microsoft Way ║ * ║ Redmond, WA 98027 ║ * ║ ║ * ║ Description: ║ * ║ This program was automatically generated by GENSCRN. ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ PARAMETERS rscused, forceregen * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ APPSCX/Windows Setup Code - SECTION 1 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * #REGION 1 PRIVATE ALL m.app_platform = "WINDOWS" * Parameter Type Description * ---------- ------ -------------------------------------------------- * rscused L Determines whether the resource file * is checked for relations * forceregen L or N Determines whether FoxApp generates full or * abbreviated project files. It can take these * values: * 1 (or .T.) Always generate full project * 2 (or .F.) Always generate abbreviated project * 3 Check CONFIG.FP for instructions * Record the status of TALK and SAFETY RELEASE app_talk, app_dele, app_safe PUBLIC app_talk, app_dele, app_safe IF SET('TALK') = 'ON' SET TALK OFF m.app_talk = 'ON' ELSE m.app_talk = 'OFF' ENDIF m.app_safe = SET("SAFETY") SET SAFETY OFF m.app_dele = SET("DELETED") SET DELETED ON IF PARAMETERS() < 2 m.forceregen = 3 && forces check of CONFIG.FP ENDIF IF PARAMETERS() < 1 m.rscused = .T. && store/restore relations from resource file? ENDIF * Map the 'forceregen' variable into numeric form. IF TYPE('forceregen') = "L" IF m.forceregen m.forceregen = 1 ELSE m.forceregen = 2 ENDIF ENDIF #REGION 0 REGIONAL m.currarea, m.talkstat, m.compstat IF SET("TALK") = "ON" SET TALK OFF m.talkstat = "ON" ELSE m.talkstat = "OFF" ENDIF m.compstat = SET("COMPATIBLE") SET COMPATIBLE FOXPLUS m.rborder = SET("READBORDER") SET READBORDER ON m.currarea = SELECT() * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ Windows Window definitions ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * IF NOT WEXIST("appgen") ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.PJX" ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.SCX" ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.MNX" ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.PRG" ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.FRX" ; OR UPPER(WTITLE("APPGEN")) == "APPGEN.QPR" DEFINE WINDOW appgen ; AT 0.000, 0.000 ; SIZE 24.308,66.833 ; TITLE " FoxPro Application Generator " ; FONT "MS Sans Serif", 8 ; STYLE "B" ; FLOAT ; NOCLOSE ; SHADOW ; NOMINIMIZE ; DOUBLE MOVE WINDOW appgen CENTER ENDIF * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ APPSCX/Windows Setup Code - SECTION 2 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * #REGION 1 * Clear out any of these public variables that may already exist RELEASE appfile, mnuname, dbfname, scxname, repname, tmfname, ; skipdbfbut, dbflist, firsttime,; origname, app_error, app_escape PUBLIC appfile, mnuname, dbfname, scxname, repname, tmfname, ; skipdbfbut, origname, app_error, app_escape * Store open databases, etc. for restoration at program termination CREATE VIEW foxapp * Set screen font to something reasonable m.scrn_font = WFONT(1,"") m.scrn_fsize = WFONT(2,"") m.scrn_fstyle = WFONT(3,"") MODIFY WINDOW SCREEN FONT "MS Sans Serif",8 STYLE "B" * Start with a clean slate--they will be restored at clean-up. CLOSE DATABASES * Note the current ON ERROR routine so that we can restore it later. m.app_error = ON('ERROR') * This ON ERROR routine is in the cleanup snippet ON ERROR DO apperror WITH PROGRAM(),MESSAGE(),MESSAGE(1),LINENO(),ERROR() * Note the current ON ESCAPE routine so that we can restore it later. m.app_escape = ON('ESCAPE') * This ON ESCAPE routine is in the cleanup snippet ON ESCAPE DO appescape WITH PROGRAM(),MESSAGE(),MESSAGE(1),LINENO(),ERROR() SET SYSMENU AUTOMATIC PUSH MENU _msysmenu m.apppathlen = 79 && maximum file and path length for file names m.dbfname = SPACE(m.apppathlen) m.scxname = SPACE(m.apppathlen) m.repname = SPACE(m.apppathlen) m.mnuname = 'APPMENU.MNX' m.generate = 0 m.cancbut = 0 m.adddbf = 0 m.addscx = 0 m.modscx = 0 m.moddbf = 0 m.dbfname = UPPER(PADR(m.dbfname,m.apppathlen)) m.scxname = UPPER(PADR(m.scxname,m.apppathlen)) m.repname = UPPER(PADR(m.repname,m.apppathlen)) m.mnuname = UPPER(PADR(m.mnuname,m.apppathlen)) * Hide the command window--necessary if we're running from the system menu. IF WVISIBLE("COMMAND") HIDE WINDOW COMMAND ENDIF m.numcols = 13 && number of columns in DBFLIST array, below m.numareas = 25 && number of database areas supported. * Set up definitions for DBFLIST array, declared when "Related" is pushed. * DBFLIST has One row per database in the FoxApp application * Row 1 contains data on the main database * * Column Meaning * 1 Stem name for child database * 2 SET RELATION command * 3 Parent field name for relation * 4 Child field name for relation * 5 Full path/filename for this child database * 6 Name of parent database * column numbers in dbflist array m.cstemnum = 1 && column number for child database stem m.relstrnum = 2 && column number for set relation string m.pfldnum = 3 && column number for parent field in the relation m.cfldnum = 4 && column number for child field in the relation m.cdbfnum = 5 && column number for child database m.pdbfnum = 6 && column number for parent database m.srownum = 7 && column number for starting row position (str) m.scolnum = 8 && column number for starting column position (str) m.erownum = 9 && column number for ending row position (str) m.ecolnum = 10 && column number for ending column position (str) m.arranged = 11 && column number for arranged? flag m.thefont = 12 && font for this browse window m.cascadenum= 13 && perform cascading deletes on this database? m.ctrlrow = MAX(ROUND(SROWS()-5.5,0),0) && default row position for control panel m.ctrlcol = MAX(ROUND(SCOLS()/2-74/2,0),0) && default column position for control panel m.nextdbf = 0 && next dbflist position, 0 at start * Make the current font the default for new windows/browses m.defaultfont = WFONT(1,"")+","+ALLTRIM(STR(WFONT(2,""),3))+","+WFONT(3,"") * Set the default for cascading deletes m.defaultcasc = 'N' * Set default options for resource file handling m.rsc_check = .F. && resource file checked for this database yet? m.rsc_stored= .F. && have current choices been saved yet? * These options can be reset on the advanced options screen. * Their default values are set based on the parameters passed to * FoxApp, or to the default value of rscused. m.retrieversc = rscused && retrieve relations from resource file? m.storersc = rscused && store relations to resource file? m.rsctype = "FOXAPP2.0A" && type code for resource file entries * Establish whether to put FoxApp SCX/SPR/MNX/MPR files into the * user's project, which makes the project organization easy to * understand and more "FoxPro-like," (called Full Projects) or PRG * files generated from the SCX/MNX files (Abbreviated Projects). * The latter approach is more confusing but is also much faster * since the FoxApp pieces (e.g., GETDEST() ) do not have to be * rebuilt whenever a user project is generated. DO CASE CASE m.forceregen = 1 m.regen = .T. CASE forceregen = 2 m.regen = .F. OTHERWISE * Assume full project generation, but check CONFIG.FP m.regen = .T. IF FILE(SYS(2019)) && find CONFIG.FP, if one exists m.fp = FOPEN(SYS(2019),0) && open CONFIG.FP read-only IF m.fp > 0 DO WHILE !FEOF(fp) m.buffer = ALLTRIM(UPPER(FGETS(m.fp))) IF LEFT(buffer,6) == 'FOXAPP' m.buffer = ALLTRIM(SUBSTR(m.buffer,AT('=',m.buffer)+1)) m.regen = ('GENERATE' $ m.buffer) ENDIF ENDDO =FCLOSE(m.fp) ELSE WAIT WINDOW "Error opening CONFIG.FP." NOWAIT ENDIF ENDIF ENDCASE * Defaults to \FOXAPP underneath FoxPro startup directory m.foxappdir = addbs(SYS(2004))+'FOXAPP' * First make sure that the FoxApp source files have been installed. * If they haven't, I can't build a project. m.foxappdir = findsrc(m.foxappdir) * It is important for the APPMENU.MPR and APPMENU.PRG files to be identical. * APPMENU relies on LOCFILE to find itself so that routines in it * can be executed, even when it is no longer in the calling chain. * The LOCFILE statements emitted by GENMENU look first for APPMENU.MPR * if it finds it, it tries to execute the procedure out of APPMENU.MPR * and reports an error if the procedure cannot be found. Since the * procedure names are generated by GENMENU off the timer, if APPMENU.MPR * and APPMENU.PRG were generated at different times, the procedures will * have different names. Thus, the files must be exact copies of each * other. The following code assures this to be the case. IF m.regen DO CASE CASE FILE('MENUS\APPMENU.PRG') AND FILE('MENUS\APPMENU.MPR') mpr_name = FULLPATH('MENUS\APPMENU.MPR') COPY FILE MENUS\appmenu.prg TO &mpr_name CASE FILE('appmenu.prg') AND FILE('appmenu.mpr') m.mpr_name = FULLPATH('appmenu.mpr') COPY FILE appmenu.prg TO &mpr_name CASE FILE('FOXAPP\MENUS\APPMENU.PRG') AND FILE('FOXAPP\MENUS\APPMENU.MPR') m.mpr_name = FULLPATH('FOXAPP\MENUS\APPMENU.MPR') COPY FILE foxapp\MENUS\appmenu.prg TO &mpr_name ENDCASE ELSE IF FILE('MENUS\APPMENU.PRG') AND FILE('MENUS\APPMENU.MPR') m.mpr_name = FULLPATH('MENUS\APPMENU.MPR') DELETE FILE &mpr_name ENDIF IF FILE('appmenu.prg') AND FILE('appmenu.mpr') m.mpr_name = FULLPATH('appmenu.mpr') DELETE FILE &mpr_name ENDIF IF FILE('FOXAPP\MENUS\APPMENU.PRG') AND FILE('FOXAPP\MENUS\APPMENU.MPR') m.mpr_name = FULLPATH('FOXAPP\MENUS\APPMENU.MPR') DELETE FILE &mpr_name ENDIF * Get the MPX files too IF FILE('MENUS\APPMENU.PRG') AND FILE('MENUS\APPMENU.MPX') m.mpx_name = FULLPATH('MENUS\APPMENU.MPX') DELETE FILE &mpx_name ENDIF IF FILE('appmenu.prg') AND FILE('appmenu.MPX') m.mpx_name = FULLPATH('appmenu.MPX') DELETE FILE &mpx_name ENDIF IF FILE('FOXAPP\MENUS\APPMENU.PRG') AND FILE('FOXAPP\MENUS\APPMENU.MPX') m.mpx_name = FULLPATH('FOXAPP\MENUS\APPMENU.MPX') DELETE FILE &mpx_name ENDIF ENDIF * Disable the Window pad while we're in the generation dialog. SET SKIP OF PAD _msm_windo OF _msysmenu .T. m.quitting = .F. && set by cancel button * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ APPSCX/Windows Screen Layout ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * #REGION 1 IF WVISIBLE("appgen") ACTIVATE WINDOW appgen SAME ELSE ACTIVATE WINDOW appgen NOSHOW ENDIF @ 12.538,50.000 GET m.addscx ; PICTURE "@*VN C\<reate" ; SIZE 1.769,10.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0oozzo() ; DISABLE @ 2.462,4.833 TO 9.539,61.666 ; PEN 1, 8 @ 12.154,4.833 TO 19.154,61.666 ; PEN 1, 8 @ 13.615,6.333 SAY "Screen name:" ; FONT "MS Sans Serif", 8 ; STYLE "B" @ 4.077,6.333 SAY "Table name:" ; FONT "MS Sans Serif", 8 ; STYLE "B" @ 11.615,6.167 SAY "Step 2 -- Create or Modify a Screen" ; FONT "MS Sans Serif", 8 ; STYLE "B" @ 1.923,6.167 SAY "Step 1 -- Create or Modify a Table" ; FONT "MS Sans Serif", 8 ; STYLE "B" @ 5.385,6.500 EDIT m.dbfname ; SIZE 1.000,49.400,67.000 ; PICTURE "@K!T" ; DEFAULT " " ; FONT "MS Sans Serif", 8 ; WHEN _qdl0op0hz() ; VALID DBFVALID() @ 2.846,50.167 GET m.adddbf ; PICTURE "@*VN \<Create" ; SIZE 1.769,10.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op103() ; DISABLE @ 4.923,50.167 GET m.moddbf ; PICTURE "@*VN \<Modify" ; SIZE 1.769,10.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op18d() ; DISABLE @ 7.462,6.333 GET m.Listdbf ; PICTURE "@*VN From \<File..." ; SIZE 1.615,13.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; WHEN _qdl0op1fe() ; VALID _qdl0op1ik() @ 7.462,46.833 GET m.other ; PICTURE "@*HN Re\<lated..." ; SIZE 1.615,13.333,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op1q5() ; DISABLE @ 14.923,6.500 EDIT scxname ; SIZE 1.000,49.400,67.000 ; PICTURE "@K!T" ; DEFAULT " " ; FONT "MS Sans Serif", 8 ; WHEN _qdl0op1y3() ; VALID _qdl0op21x() @ 14.538,50.167 GET m.modscx ; PICTURE "@*VN M\<odify" ; SIZE 1.769,10.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; WHEN _qdl0op29j() ; VALID _qdl0op2d6() ; DISABLE @ 17.077,6.333 GET m.Listscx ; PICTURE "@*VN From F\<ile..." ; SIZE 1.615,13.000,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op2jn() @ 21.154,6.333 GET m.generate ; PICTURE "@*VN \!\<Generate" ; SIZE 1.769,17.167,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op2qf() @ 21.077,46.667 GET m.advanced ; PICTURE "@*HN Ad\<vanced..." ; SIZE 1.769,14.833,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op7bf() @ 21.154,24.500 GET m.cancbut ; PICTURE "@*VN \?\<Cancel" ; SIZE 1.769,17.167,1.000 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op7gh() @ 17.077,46.833 GET m.arrange ; PICTURE "@*HN \<Arrange" ; SIZE 1.615,13.333,0.667 ; DEFAULT 1 ; FONT "MS Sans Serif", 8 ; STYLE "B" ; VALID _qdl0op7lu() ; DISABLE IF NOT WVISIBLE("appgen") ACTIVATE WINDOW appgen ENDIF READ CYCLE MODAL ; DEACTIVATE _qdl0op90p() ; SHOW SCRNUPD() RELEASE WINDOW appgen SELECT (m.currarea) #REGION 0 SET READBORDER &rborder IF m.talkstat = "ON" SET TALK ON ENDIF IF m.compstat = "ON" SET COMPATIBLE ON ENDIF * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ APPSCX/Windows Cleanup Code ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * #REGION 1 * Cleanup code to construct CDX file and start the application * If cancel button pressed, quit now IF m.quitting DO close_up ENDIF * This SET TALK OFF is necessary because the screen generator restores * the original TALK setting before executing the cleanup snippet. SET TALK OFF m.scxname = ALLTRIM(UPPER(m.scxname)) m.dbfname = ALLTRIM(UPPER(m.dbfname)) IF !FILE(m.scxname) WAIT WINDOW "The screen file is missing." DO close_up ENDIF IF !FILE(m.dbfname) WAIT WINDOW "The database file is missing." DO close_up ENDIF * Invert the database if there isn't a CDX file present already m.invstem = juststem(m.dbfname) m.cdxname = forceext(m.dbfname,'CDX') IF FILE(m.cdxname) IF USED(m.invstem) SELECT (m.invstem) ELSE SELECT 0 USE (LOCFILE(m.dbfname,'DBF','Locate '+m.dbfname+' please')) ENDIF * Ensure that the database isn't empty IF RECCOUNT() = 0 APPEND BLANK ENDIF ELSE DO invert WITH m.dbfname ENDIF * Display a message telling the user how to run the * generated application in the future. CLEAR WINDOW GOTO TOP CLEAR m.fnt_face = "MS Sans Serif" m.fnt_size = 8 m.fnt_style = "B" * Figure out how big the panel needs to be in the current screen font m.tr1 = 4 * FONTMETRIC(1,m.fnt_face, m.fnt_size, m.fnt_style) ; / FONTMETRIC(1,WFONT(1,""),WFONT(2,""),WFONT(3,"")) m.tr2 = 18 * FONTMETRIC(1,m.fnt_face, m.fnt_size, m.fnt_style) ; / FONTMETRIC(1,WFONT(1,""),WFONT(2,""),WFONT(3,"")) m.tc1 = 6 * FONTMETRIC(1,m.fnt_face, m.fnt_size, m.fnt_style) ; / FONTMETRIC(1,WFONT(1,""),WFONT(2,""),WFONT(3,"")) m.tc2 = 66 * FONTMETRIC(1,m.fnt_face, m.fnt_size, m.fnt_style) ; / FONTMETRIC(1,WFONT(1,""),WFONT(2,""),WFONT(3,"")) DO putpanel WITH "appdoc",.T.,m.tr1,m.tc1,m.tr2,m.tc2,.5,.7 SET CURSOR OFF m.in_wrap = _WRAP m.in_lmargin = _LMARGIN m.in_rmargin = _RMARGIN @ 3,1 SAY ' FoxApp has created an application named '+justfname(m.appfile) ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 4,1 SAY ' in the '+justpath(m.appfile)+' directory.' ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 6,1 SAY ' You can run your application now by pressing any key.' ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 7,1 SAY ' To run it in the future, simply select "Application"' ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 8,1 SAY ' from the RUN menu, or enter FoxPro and type:' ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 9,1 SAY ' SET DEFAULT TO '+justpath(m.appfile) ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style @ 10,1 SAY ' DO '+justfname(m.appfile) ; FONT m.fnt_face,m.fnt_size STYLE m.fnt_style WAIT WINDOW "Press any key to start your application." * Restore margin and wrap settings t _WRAP = m.in_wrap _RMARGIN = m.in_rmargin _LMARGIN = m.in_lmargin RELEASE WINDOW appdoc SET CURSOR ON * Release PUBLIC variables that are no longer needed RELEASE scxname, dbfname, invname, cdxname, repname, tmfname RELEASE bailout, skipdbfbut, origname, dbflist, mnuname CLOSE DATABASES CLEAR PROGRAM POP MENU _msysmenu * Appshell starts the m.appfile application. Upon return from m.appfile, * it prompts for another application to run. DO appshell WITH m.appfile DO close_up RETURN * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ APPSCX/Windows Supporting Procedures and Functions ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * #REGION 1 PROCEDURE close_up * Do closing housekeeping for FoxApp. RELEASE scxname, dbfname, invname, cdxname, repname, tmfname, ; bailout, skipdbfbut, origname, dbflist, mnuname, appfile RELEASE origdbflist CLOSE DATABASES CLEAR WINDOW * Restore the PUSH-ed system menu POP MENU _msysmenu CLEAR PROGRAM m.scrn_font = WFONT(1,"") m.scrn_fsize = WFONT(2,"") m.scrn_fstyle = WFONT(3,"") MODIFY WINDOW SCREEN FONT m.scrn_font,m.scrn_fsize STYLE m.scrn_fstyle * Restore original ON ERROR & ON ESCAPE routines ON ERROR &app_error ON ESCAPE &app_escape RELEASE app_error, app_escape * Get rid of any vue files that might be hanging around IF FILE('qprview.vue') DELETE FILE qprview.vue ENDIF IF FILE('appview.vue') DELETE FILE appview.vue ENDIF IF FILE('dbfselec.vue') DELETE FILE dbfselec.vue ENDIF IF FILE('foxapp.vue') SET VIEW TO foxapp DELETE FILE foxapp.vue ENDIF IF m.app_talk = "ON" SET TALK ON ENDIF IF m.app_dele = "OFF" SET DELETED OFF ENDIF IF m.app_safe = "ON" SET SAFETY ON ENDIF RELEASE app_talk, app_safe, app_dele, dbflist CANCEL PROCEDURE copypiece * Copy FoxApp pieces to project directory fxpath = addbs(foxappdir) && probably C:\foxpro2\foxapp\ projdir = addbs(justpath(m.appfile)) =putout('prgs\appproc.prg',m.fxpath,m.projdir) =putout('menus\appmenu.mnx',m.fxpath,m.projdir) =putout('menus\appmenu.mnt',m.fxpath,m.projdir) =putout('screens\getdest.scx',m.fxpath,m.projdir) =putout('screens\getdest.sct',m.fxpath,m.projdir) =putout('screens\getorder.scx',m.fxpath,m.projdir) =putout('screens\getorder.sct',m.fxpath,m.projdir) =putout('screens\appabout.scx',m.fxpath,m.projdir) =putout('screens\appabout.sct',m.fxpath,m.projdir) =putout('screens\appsrch.scx',m.fxpath,m.projdir) =putout('screens\appsrch.sct',m.fxpath,m.projdir) =putout('screens\prtsetup.scx',m.fxpath,m.projdir) =putout('screens\prtsetup.sct',m.fxpath,m.projdir) =putout('screens\prtopts.scx',m.fxpath,m.projdir) =putout('screens\prtopts.sct',m.fxpath,m.projdir) =putout('screens\appctrl.scx',m.fxpath,m.projdir) =putout('screens\appctrl.sct',m.fxpath,m.projdir) FUNCTION putout * Copies a file with name "Pathname" from the path specified in "source" * the the "target" path. PARAMETERS pathname, source, target PRIVATE pathname, source, target, filname, file1, file2 m.filname = justfname(m.pathname) m.target = addbs(m.target) m.source = addbs(m.source) m.file1 = m.source + m.pathname m.file2 = m.target + m.filname IF FILE(m.file1) COPY FILE &file1 TO &file2 ENDIF FUNCTION findsrc parameter appdir * Make sure that the FoxApp source files have been installed. * If they haven't, I can't build a project. m.targfile = addbs(SYS(2004))+'FOXAPP\FOXAPP.SRC' IF !FILE(m.targfile) m.targfile = addbs(SYS(2004))+'FOXAPPW\FOXAPP.SRC' IF !FILE(m.targfile) * See if we are in the FOXAPP directory itself then m.targfile = addbs(SYS(2004))+'GOODIES\FOXAPP\FOXAPP.SRC' IF !FILE(m.targfile) * See if we are in the FOXAPP directory itself then m.targfile = addbs(CURDIR())+'FOXAPP.SRC' IF !FILE(m.targfile) WAIT WINDOW "FoxApp source files must be available to build projects." NOWAIT m.targfile = GETFILE('SRC','Please locate the FOXAPP.SRC file:') IF EMPTY(m.targfile) DO alert WITH "FoxApp cannot build a full project without its source files." DO close_up RETURN '' ELSE m.newpath = SET('PATH')+';'+justpath(m.targfile) SET PATH TO (m.newpath) ENDIF ENDIF ENDIF ENDIF ENDIF RETURN justpath(m.targfile) FUNCTION versiondate * Returns the FoxPro build date as a date value * VERSION(1) returns a string like this: * FoxPro/LAN 2.0 (X) [Nov 15 1991 16:16:06] Serial # DEV001296 * We want to return 11/15/91 as a date value m.v1 = VERSION(1) * extract the portion of the VERSION(1) string between the brackets m.vdatestr = SUBSTR(m.v1,AT('[',m.v1)+1,RAT(']',m.v1)-AT('[',m.v1)) * extract just the date portion of the date/time string m.vdatestr = ALLTRIM(SUBSTR(m.vdatestr,1,AT(' ',m.vdatestr,3)-1)) * Pull out the month abbreviation and figure out which month number it is m.vmonthstr = UPPER(SUBSTR(m.vdatestr,1,3)) DO CASE CASE INLIST(m.vmonthstr,'JANUARY','JAN') m.vmonth = 1 CASE INLIST(m.vmonthstr,'FEBRUARY','FEB') m.vmonth = 2 CASE INLIST(m.vmonthstr,'MARCH','MAR') m.vmonth = 3 CASE INLIST(m.vmonthstr,'APRIL','APR') m.vmonth = 4 CASE INLIST(m.vmonthstr,'MAY') m.vmonth = 5 CASE INLIST(m.vmonthstr,'JUNE','JUN') m.vmonth = 6 CASE INLIST(m.vmonthstr,'JULY','JUL') m.vmonth = 7 CASE INLIST(m.vmonthstr,'AUGUST','AUG') m.vmonth = 8 CASE INLIST(m.vmonthstr,'SEPTEMBER','SEP','SEPT') m.vmonth = 9 CASE INLIST(m.vmonthstr,'OCTOBER','OCT') m.vmonth = 10 CASE INLIST(m.vmonthstr,'NOVEMBER','NOV') m.vmonth = 11 CASE INLIST(m.vmonthstr,'DECEMBER','DEC') m.vmonth = 12 ENDCASE * Reconstruct the string by using the month number m.vdatestr = STR(m.vmonth,2)+'/'+LTRIM(SUBSTR(m.vdatestr,AT(' ',m.vdatestr))) * Replace spaces with slashes m.vdatestr = CHRTRAN(m.vdatestr,' ','/') RETURN CTOD(m.vdatestr) FUNCTION trimzero * Trims ASCII 0 characters from strg PARAMETER m.strg RETURN CHRTRAN(m.strg,CHR(0),"") FUNCTION forceext * Force the extension of "filname" to be whatever ext is. PARAMETERS filname,ext PRIVATE ALL IF SUBSTR(m.ext,1,1) = "." m.ext = SUBSTR(m.ext,2,3) ENDIF m.pname = justpath(m.filname) m.filname = justfname(UPPER(ALLTRIM(m.filname))) IF AT('.',m.filname) > 0 m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) + '.' + m.ext ELSE m.filname = m.filname + '.' + m.ext ENDIF RETURN addbs(m.pname) + m.filname FUNCTION defaultext * Force the extension of "filname" to be whatever ext is, unless it * already has an extension. PARAMETERS filname,ext PRIVATE ALL IF EMPTY(justext(m.filname)) RETURN forceext(m.filname,m.ext) ELSE RETURN m.filname ENDIF FUNCTION justfname * Return just the filename (i.e., no path) from "filname" PARAMETERS filname PRIVATE ALL IF RAT('\',m.filname) > 0 m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255) ENDIF IF AT(':',m.filname) > 0 m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255) ENDIF RETURN ALLTRIM(UPPER(m.filname)) FUNCTION juststem * Return just the stem name from "filname" PARAMETERS m.filname PRIVATE ALL IF RAT('\',m.filname) > 0 m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255) ENDIF IF AT(':',m.filname) > 0 m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255) ENDIF IF AT('.',m.filname) > 0 m.filname = SUBSTR(m.filname,1,AT('.',m.filname)-1) ENDIF RETURN ALLTRIM(UPPER(m.filname)) FUNCTION justext * Return just the extension from "filname" PARAMETERS m.filname PRIVATE ALL filname = JustFname(m.filname) && prevents problems with ..\ paths m.ext = "" IF AT('.',m.filname) > 0 m.ext = SUBSTR(m.filname,AT('.',m.filname)+1,3) ENDIF RETURN UPPER(m.ext) FUNCTION justpath * Return just the path name from "filname" PARAMETERS m.filname PRIVATE ALL m.filname = ALLTRIM(UPPER(m.filname)) IF '\' $ m.filname m.filname = SUBSTR(m.filname,1,RAT('\',m.filname)) IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ; AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':' m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1) ENDIF RETURN m.filname ELSE RETURN '' ENDIF FUNCTION addbs * Add a backslash to a path name if there isn't already one there PARAMETER m.pathname PRIVATE ALL m.pathname = ALLTRIM(UPPER(m.pathname)) IF !(RIGHT(m.pathname,1) $ '\:') AND !EMPTY(m.pathname) m.pathname = m.pathname + '\' ENDIF RETURN m.pathname FUNCTION term * Returns the item-th term from string strg, where a term is a set of characters * separated by commas. PARAMETERS m.strg, m.item m.numcommas = OCCURS(",",strg) IF m.item > m.numcommas + 1 RETURN "" ELSE DO CASE CASE m.item = 1 RETURN LEFT(m.strg,AT(",",m.strg)-1) CASE m.item = m.numcommas + 1 RETURN SUBSTR(m.strg,RAT(",",m.strg)+1) OTHERWISE RETURN SUBSTR(m.strg,AT(",",m.strg,m.item-1)+1,; AT(",",m.strg,m.item) - AT(",",m.strg,m.item-1) - 1) ENDCASE ENDIF PROCEDURE invert * Completely invert the "filname" database into a CDX file, creating * an index tag on each field. PARAMETERS m.filname PRIVATE m.filname, m.i, m.safe_stat, m.comp_stat, m.in_area, m.fldname m.comp_stat = SET("COMPATIBLE") m.safe_stat = SET("SAFETY") SET COMPATIBLE TO FOXPLUS SET SAFETY OFF m.in_area = SELECT() && currently selected area m.fstem = juststem(m.filname) IF USED(m.fstem) SELECT (m.fstem) ELSE SELECT 0 USE (m.filname) ENDIF FOR m.i = 1 TO FCOUNT() m.fldname = FIELD(m.i) WAIT WINDOW "Indexing on "+m.fldname + "." NOWAIT IF TYPE(m.fldname) <> "M" AND TYPE(m.fldname) <> "G" IF TYPE(m.fldname) = "C" AND LEN(&fldname) >= 99 INDEX ON SUBSTR(&fldname,1,99) TO (m.fldname) ELSE INDEX ON &fldname TAG (m.fldname) ENDIF ENDIF ENDFOR WAIT WINDOW "Indexing for "+m.fstem+" is complete!" NOWAIT IF m.in_area <> SELECT() USE ENDIF SELECT (m.in_area) IF m.comp_stat = "ON" OR m.comp_stat = "DB4" SET COMPATIBLE TO DB4 ENDIF IF m.safe_stat = "ON" SET SAFETY ON ENDIF RETURN PROCEDURE mergectrl * Merge the FoxApp control panel into user's screen to create a * screen set. This routine also forces all other screens to be * modal. PARAMETERS m.pjxname, m.scxname, m.ctrl_y, m.ctrl_x PRIVATE pjxname, scxname, in_area, ctrl_y, ctrl_x, sname, ctrl_name m.in_area = SELECT() * name of the control panel screen, as it exists inside FOXAPP.APP * (or copied onto the disk, if regen is in effect) IF m.regen m.ctrl_scx = addbs(justpath(m.pjxname))+'APPCTRL.SCX' ELSE m.ctrl_scx = addbs(SYS(2004))+'FOXAPP\SCREENS\APPCTRL.SCX' ENDIF SELECT 0 USE (m.ctrl_scx) AGAIN ALIAS ctrlscx REPLACE ctrlscx.hpos WITH m.ctrl_x, ctrlscx.vpos WITH m.ctrl_y USE * Quit now if the project file is hiding. IF !FILE(m.pjxname) RETURN ENDIF IF USED(juststem(m.pjxname)) * Open it again with the 'pjxfile' alias. m.sname = juststem(m.pjxname) SELECT &sname ELSE SELECT 0 ENDIF USE (m.pjxname) ALIAS pjxfile * Find the home directory LOCATE FOR UPPER(pjxfile.type) == "H" IF FOUND() m.homename = pjxfile.homedir ELSE m.homename = CURDIR() ENDIF * Locate the master screen set record LOCATE FOR UPPER(justfname(trimzero(pjxfile.name))) ; == UPPER(forceext(justfname(m.scxname),'SPR')) AND pjxfile.type = 'S' IF FOUND() m.setnum = pjxfile.setid * Now locate the user screen SCX record GOTO TOP LOCATE FOR UPPER(justfname(trimzero(pjxfile.name))) == UPPER(justfname(m.scxname)) ; AND setid = m.setnum IF FOUND() * Use the coordinates stored in the screen file itself. These * reflect the changes that the user made to the screen location * while inside FoxApp. REPLACE pjxfile.arranged WITH "WINDOWS"+CHR(0)+"N"+"N"; +PADL(LTRIM(STR(m.ctrl_y,4)),8)+PADL(LTRIM(STR(m.ctrl_x,4)),8) REPLACE pjxfile.scrnorder WITH 0 ENDIF * Figure out how many screens are in this screen set (usually 1 * if this is a FoxApp generated app, but perhaps the user has * added some more screens). GOTO TOP COUNT FOR pjxfile.setid = m.setnum TO m.ctrl_order * Put the control panel into the project as a screen set member * of the user's screen set. If it is already there, update it. * If not, create a new record and insert it. GOTO TOP LOCATE FOR justfname(UPPER(ALLTRIM(trimzero(pjxfile.name)))) ; == UPPER(justfname(m.ctrl_scx)) IF !FOUND() APPEND BLANK ELSE m.ctrl_order = m.ctrl_order - 1 && don't count existing one ENDIF * Update the project file to point to the control panel as part of the * user screen set. IF m.regen m.user_scx = m.ctrl_scx ELSE m.user_scx = SYS(2014,m.ctrl_scx,m.pjxname) ENDIF REPLACE pjxfile.name WITH m.user_scx, ; pjxfile.TYPE WITH 's', ; pjxfile.setid WITH m.setnum, ; pjxfile.timestamp WITH 0, ; pjxfile.exclude WITH .F., ; pjxfile.scrnorder WITH m.ctrl_order ELSE * This means that something went badly wrong during BUILD PROJECT WAIT WINDOW "FoxApp could not complete this application." SET DEFAULT TO &c_path DO close_up CANCEL ENDIF USE SELECT (in_area) PROCEDURE initdbflist * Initialize the DBFLIST array PRIVATE m.i,m.j PUBLIC dbflist[m.numareas,m.numcols] * Format the stem names for the popup FOR m.i = 1 TO m.numareas dbflist[m.i,m.cstemnum] = '\' && start everything off disabled dbflist[m.i,m.arranged] = "N" && user hasn't arranged the screen yet dbflist[m.i,m.theFont] = defaultfont dbflist[m.i,m.cascadenum] = defaultcasc ENDFOR * Initialize the other columns in the dbflist array, except screen * positions FOR m.i = 1 TO m.numareas FOR m.j = 2 TO m.srownum - 1 dbflist[m.i,m.j] = '' ENDFOR ENDFOR * Initialize the screen positions FOR m.i = 1 TO m.numareas dbflist[m.i,m.srownum] = ALLTRIM(STR(m.i,3)) dbflist[m.i,m.scolnum] = ALLTRIM(STR(m.i,3)) dbflist[m.i,m.erownum] = "6" && 6 rows high dbflist[m.i,m.ecolnum] = ALLTRIM(STR(76-m.i,3)) && width ENDFOR FUNCTION opendbf * Open a DBF and return the alias, or blanks if the database could * not be opened. PARAMETERS fname PRIVATE fname, stem IF FILE(m.fname) m.stem = juststem(m.fname) IF USED(m.stem) SELECT (m.stem) ELSE SELECT 0 m.fname = LOCFILE(m.fname,'DBF','Please locate the database') IF EMPTY(m.fname) RETURN '' ELSE USE (m.fname) ENDIF ENDIF RETURN ALIAS() ELSE RETURN '' ENDIF PROCEDURE createscx PRIVATE maxh, maxv, s_name * Create a quick-screen SCX file from the named database m.scxname = ALLTRIM(m.scxname) IF !EMPTY(opendbf(m.dbfname)) m.s_name = addbs(justpath(m.scxname)) + juststem(m.scxname) && don't need extension WAIT WINDOW "Creating screen "+m.s_name NOWAIT CREATE SCREEN (m.s_name) FROM (m.dbfname) ROW m.scxname = forceext(m.scxname,"SCX") IF FILE(m.scxname) SHOW GET addscx DISABLE SHOW GET modscx ENABLE ENDIF IF !EMPTY(m.scxname) SELECT 0 USE (m.scxname) ALIAS fxscxname REPLACE fxscxname.width WITH MIN(SCOLS(),fxscxname.width) m.maxh = width m.maxv = height IF relateddbfs() AND UPPER(dbflist[1,m.arranged]) = "N" * No screen position yet defined for the main database. Center it, * unless there are lots of related databases. If there are, put * it closer to the top of the screen. IF m.nextdbf < 3 && just one database used in app m.start_row = MAX(INT(SROWS()/2-height/2),0) m.start_col = MAX(INT(SCOLS()/2-width/2),0) ELSE m.start_row = 1 m.start_col = MAX(INT(SCOLS()/2-width/2),0) ENDIF ELSE && center the screen horizontally if it hasn't been arranged. m.start_row = 1 m.start_col = MAX(INT(SCOLS()/2-width/2),0) ENDIF m.start_row = MAX(0,m.start_row) m.start_col = MAX(0,m.start_col) REPLACE ALL fxscxname.vpos WITH m.start_row, fxscxname.hpos WITH m.start_col; FOR objtype = 1 AND platform = "WINDOWS" * Make some space around the fields REPLACE ALL fxscxname.hpos WITH fxscxname.hpos + 1,; fxscxname.vpos WITH fxscxname.vpos + 1 ; FOR objtype > 4 AND objtype <> 23 AND platform = "WINDOWS" SCAN FOR objtype > 4 and objtype <> 23 m.thish = fxscxname.hpos + fxscxname.width ; * FONTMETRIC(6,fxscxname.fontface,fxscxname.fontsize, ; whatstyle(fxscxname.fontstyle)) ; / FONTMETRIC(6,WFONT(1,""),WFONT(2,""),WFONT(3,"")) m.thisv = fxscxname.vpos + fxscxname.height ; * FONTMETRIC(1,fxscxname.fontface,fxscxname.fontsize, ; whatstyle(fxscxname.fontstyle)) ; / FONTMETRIC(1,WFONT(1,""),WFONT(2,""),WFONT(3,"")) m.maxh = MAX(m.thish,m.maxh) m.maxv = MAX(m.thisv,m.maxv) ENDSCAN GOTO TOP REPLACE fxscxname.center WITH .T.,; fxscxname.width WITH m.maxh + 6, ; fxscxname.height WITH m.maxv + 1,; fxscxname.name WITH juststem(m.scxname), ; fxscxname.style WITH 2,; fxscxname.border WITH 1,; fxscxname.tag WITH '" '+juststem(m.scxname)+' "' IF relateddbfs() dbflist[1,m.srownum] = ALLTRIM(STR(m.start_row,4)) dbflist[1,m.scolnum] = ALLTRIM(STR(m.start_col,4)) dbflist[1,m.erownum] = ALLTRIM(STR(fxscxname.height,4)) dbflist[1,m.ecolnum] = ALLTRIM(STR(fxscxname.width,4)) ENDIF USE ENDIF WAIT WINDOW "Screen has been created." NOWAIT ELSE DO errshow WITH "Database could not be opened.",10 ENDIF SHOW GETS RETURN FUNCTION filattr * Return file attributes of "filname" PARAMETER m.filname PRIVATE filarray, m.filpos m.filname = UPPER(ALLTRIM(m.filname)) IF ADIR(filarray,m.filname) > 0 m.filpos = ASCAN(filarray,justfname(m.filname)) IF m.filpos > 0 RETURN filarray[m.filpos,5] ENDIF ENDIF RETURN '' FUNCTION relateddbfs * RETURN T if related DBF files have been defined through FoxApp RETURN m.nextdbf > 2 FUNCTION getdbflist * Retrieve dbflist from resource file PARAMETERS cstem PRIVATE m.nextdbf, m.in_area, m.cstem, m.i, m.j, m.j1_at, m.j2_at IF !FILE(SYS(2005)) && resource file not found. RETURN 0 ENDIF m.nextdbf = 0 m.in_area = SELECT(0) m.cstem = UPPER(ALLTRIM(m.cstem)) IF EMPTY(m.cstem) RETURN 0 ENDIF m.memwidth = SET('MEMOWIDTH') SET MEMOWIDTH TO 255 SELECT 0 USE (SYS(2005)) AGAIN ALIAS rsc LOCATE FOR UPPER(ALLTRIM(rsc.type)) == m.rsctype; AND UPPER(ALLTRIM(rsc.id)) == 'DBFLIST' ; AND UPPER(ALLTRIM(rsc.name)) == m.cstem ; AND !DELETED() IF FOUND() AND !EMPTY(rsc.data) WAIT WINDOW "Retrieving stored relationships." NOWAIT IF TYPE("dbflist") = "U" DO initdbflist ENDIF * First get the position of the control panel m.ctrlline = MLINE(rsc.data,1) m.ctrlrow = VAL(SUBSTR(m.ctrlline,1,AT(';',m.ctrlline)-1)) m.ctrlcol = VAL(SUBSTR(m.ctrlline,AT(';',m.ctrlline)+1)) FOR m.i = 1 TO m.numareas m.this_dbf = MLINE(rsc.data,m.i+1) FOR m.j = 1 TO m.numcols DO CASE CASE m.j = 1 IF AT(';',m.this_dbf) = 1 dbflist[m.i,m.j] = '\' && make this empty area disabled in the list ELSE dbflist[m.i,m.j] = SUBSTR(m.this_dbf,1,AT(';',m.this_dbf)-1) ENDIF CASE m.j = m.numcols dbflist[m.i,m.j] = SUBSTR(m.this_dbf,AT(';',m.this_dbf,m.numcols-1)+1) OTHERWISE m.j1_at = AT(';',m.this_dbf,m.j-1) m.j2_at = AT(';',m.this_dbf,m.j) dbflist[m.i,m.j] = SUBSTR(m.this_dbf,m.j1_at + 1,m.j2_at - m.j1_at - 1) ENDCASE ENDFOR IF !EMPTY(dbflist[m.i,m.cstemnum]) ; AND dbflist[m.i,m.cstemnum] <> '\' ; AND !USED(dbflist[m.i,m.cstemnum]) IF !FILE(dbflist[m.i,m.cdbfnum]) * See if we can find it anywhere along the path IF FILE(FULLPATH(dbflist[m.i,m.cdbfnum])) dbflist[m.i,m.cdbfnum] = FULLPATH(dbflist[m.i,m.cdbfnum]) dbflist[m.i,m.cstemnum] = juststem(dbflist[m.i,m.cdbfnum]) ELSE && it is nowhere to be found. Ask where it is. dbflist[m.i,m.cdbfnum] = GETFILE('DBF',; 'Where is '+juststem(dbflist[m.i,m.cdbfnum])+'?') IF EMPTY(dbflist[m.i,m.cdbfnum]) OR !FILE(dbflist[m.i,m.cdbfnum]) DO alert WITH dbflist[m.i,m.cstemnum]+" could not be found!" DO close_up ENDIF ENDIF ENDIF dbflist[m.i,m.cstemnum] = juststem(dbflist[i,m.cdbfnum]) IF FILE(dbflist[m.i,m.cdbfnum]) * full name of database including path SELECT 0 USE (dbflist[m.i,m.cdbfnum]) AGAIN ENDIF * Ensure that this database has a corresponding CDX file DO makecdx WITH dbflist[m.i,m.cdbfnum], dbflist[m.i,m.cfldnum] ENDIF * Record the first open database area IF !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' m.nextdbf = m.i+1 ENDIF ENDFOR WAIT CLEAR ENDIF SELECT rsc USE SELECT (m.in_area) SET MEMOWIDTH TO m.memwidth RETURN m.nextdbf FUNCTION putdbflist PARAMETERS cstem PRIVATE m.cstem, m.in_area, m.i, m.j, m.repl_str * Store the dbflist array in the resource file * * The format for storing the dbflist array in the data memo field is: * string;string;string;string... CHR(13)+CHR(10) IF !FILE(SYS(2005)) OR EMPTY(m.cstem) RETURN 0 ENDIF * Don't update if this is a read-only file * SYS(2026,filename) is a last-minute function that returns 'Y' if the * file is both open and marked read-only, for any reason (e.g., it's in an APP, it's * the resource file for another instance of FoxPro, etc.) IF 'R' $ filattr(SYS(2005)) OR SYS(2026,SYS(2005)) <> "N" WAIT WINDOW "Resource file is read-only. Not updated." NOWAIT m.storersc = .F. =INKEY(2) RETURN 0 ENDIF m.cstem = UPPER(ALLTRIM(m.cstem)) m.in_area = SELECT() SELECT 0 USE (SYS(2005)) AGAIN ALIAS rsc LOCATE FOR UPPER(ALLTRIM(rsc.type)) == m.rsctype ; AND UPPER(ALLTRIM(rsc.id)) == 'DBFLIST' ; AND UPPER(ALLTRIM(rsc.name)) == m.cstem IF !FOUND() APPEND BLANK ELSE IF rsc.readonly WAIT WINDOW "Existing resource record is read-only. Not updated." NOWAIT =INKEY(1) && wait 1 second USE SELECT (m.in_area) RETURN 0 ENDIF ENDIF * Write out the control panel upper left coordinates first m.repl_str = ALLTRIM(STR(m.ctrlrow,7,3))+';'; +ALLTRIM(STR(m.ctrlcol,7,3))+CHR(13)+CHR(10) * Write the dbflist data for each row/col FOR m.i = 1 TO m.numareas FOR m.j = 1 TO m.numcols m.repl_str = m.repl_str +IIF(m.j=1,'',';') ; + IIF(INLIST(TYPE("dbflist[m.i,m.j]"),'U','L'),'',TRIM(dbflist[m.i,m.j])); + IIF(m.j=m.numcols,CHR(13)+CHR(10),'') ENDFOR ENDFOR REPLACE rsc.data WITH m.repl_str, ; rsc.type WITH m.rsctype, ; rsc.id WITH 'DBFLIST', ; rsc.name WITH m.cstem, ; rsc.ckval WITH VAL(SYS(2007,rsc.data)),; rsc.updated WITH DATE(),; rsc.readonly WITH .F. * Set the flag that notifies the rest of the program that the * relations have been stored in the resource file. rsc_stored = .T. USE SELECT (m.in_area) RETURN 0 PROCEDURE makecdx parameter filname, tagname * Ensure that filename has a CDX file with a tag name of tagname PRIVATE m.filname, m.tagname, m.cdxname, m.i, m.justtag justtag = m.tagname * Strip off alias names from fields like parent.fldname IF AT('.',m.justtag) > 0 m.justtag = ALLTRIM(UPPER(SUBSTR(m.justtag,AT('.',m.justtag)+1))) ENDIF cdxname = forceext(m.filname,'CDX') =opendbf(m.filname) DO CASE CASE !FILE(m.cdxname) DO invert WITH m.filname OTHERWISE * Cycle through the tags looking for one to match the key field m.i = 1 DO WHILE (TAG(m.cdxname,m.i) != m.justtag) ; AND !EMPTY(TAG(m.cdxname,m.i)) m.i = m.i + 1 ENDDO IF EMPTY(TAG(m.cdxname,m.i)) DO invert WITH m.filname ENDIF ENDCASE PROCEDURE definewindow * Defines a window for use by the error reporting routines parameter m.hight, m.width, m.name, m.scheme PRIVATE m.fromrow, m.fromcol, m.torow, m.tocol m.fromrow = INT((srow()-m.hight)/2) m.fromcol = INT((scol()-m.width)/2) m.torow = m.fromrow + m.hight m.tocol = m.fromcol + m.width DEFINE WINDOW (m.name); FROM m.fromrow, m.fromcol TO m.torow, m.tocol; FLOAT NOGROW NOCLOSE NOZOOM SHADOW DOUBLE; COLOR SCHEME (m.scheme) RETURN FUNCTION maptochar * Maps the numeric values used in SCX files to the string that FONTMETRIC needs PARAMETERS stylenum DO CASE CASE m.stylenum = 0 RETURN "" CASE m.stylenum = 1 RETURN "B" CASE m.stylenum = 2 RETURN "I" CASE m.stylenum = 3 RETURN "BI" OTHERWISE RETURN "" ENDCASE FUNCTION tranfont * Translates coordinates from one font to another PARAMETERS units, code, fromfont, fromsize, fromstyle, tofont, tosize, tostyle * Units is the width/height term * code = 1 for height, 6 for width PRIVATE strflag, retval IF PARAMETERS() < 8 m.tostyle = WFONT(3,"") ENDIF IF PARAMETERS() < 7 m.tosize = WFONT(2,"") ENDIF IF PARAMETERS() < 6 m.tofont = WFONT(1,"") ENDIF m.strflag = .F. IF TYPE("units") = "C" m.units = VAL(m.units) m.strflag = .T. ENDIF IF TYPE("fromstyle") = "N" m.fromstyle = MapToChar(m.fromstyle) ENDIF IF TYPE("tostyle") = "N" m.tostyle = MapToChar(m.tostyle) ENDIF IF TYPE("tosize") = "C" m.tosize = VAL(m.tosize) ENDIF IF TYPE("fromsize") = "C" m.fromsize = VAL(m.fromsize) ENDIF m.tofont = FONTMETRIC(m.code,m.tofont, m.tosize, m.tostyle) m.fromfont = FONTMETRIC(m.code,m.fromfont,m.fromsize,m.fromstyle) IF m.tofont <> 0 && avoid division by zero retval = m.units * m.fromfont / m.tofont * 1.00 IF strflag retval = ALLTRIM(STR(retval,10)) ENDIF ELSE retval = IIF(strflag,"0",0) ENDIF RETURN retval PROCEDURE arrsave * Save arrangement of windows and return to dbfselect screen * Set exit flag for READ VALID--can't be PRIVATE m.arrexflg = .T. * Record window coordinates and release all the application windows m.ctrlrow = WLROW('CTRL') m.ctrlcol = WLCOL('CTRL') RELEASE WINDOW ctrl * Store the coordinates for the main window IF !EMPTY(dbflist[1,m.cstemnum]) AND dbflist[1,m.cstemnum] <> '\' dbflist[1,m.srownum] = ALLTRIM(STR(WLROW(dbflist[1,m.cstemnum]),7,3)) dbflist[1,m.scolnum] = ALLTRIM(STR(WLCOL(dbflist[1,m.cstemnum]),7,3)) dbflist[1,m.erownum] = ALLTRIM(STR(WROWS(dbflist[1,m.cstemnum]),7,3)) dbflist[1,m.ecolnum] = ALLTRIM(STR(WCOLS(dbflist[1,m.cstemnum]),7,3)) RELEASE WINDOW (dbflist[1,m.cstemnum]) ENDIF dbflist[1,m.arranged] = "Y" FOR m.i = 2 TO m.numareas IF !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' dbflist[m.i,m.srownum] = ALLTRIM(STR(WLROW(dbflist[m.i,m.cstemnum]),7,3)) dbflist[m.i,m.scolnum] = ALLTRIM(STR(WLCOL(dbflist[m.i,m.cstemnum]),7,3)) * WROWS() reports one more pixel than we want. dbflist[m.i,m.erownum] = ALLTRIM(STR(WROWS(dbflist[m.i,m.cstemnum]) - 1/FONTMETRIC(1),7,3)) dbflist[m.i,m.ecolnum] = ALLTRIM(STR(WCOLS(dbflist[m.i,m.cstemnum]),7,3)) RELEASE WINDOW (dbflist[m.i,m.cstemnum]) ENDIF dbflist[m.i,m.arranged] = "Y" ENDFOR * Store relations into resource file if needed IF TYPE("DBFLIST") <> "U" AND !rsc_stored AND m.storersc WAIT WINDOW "Saving window positions." NOWAIT DO putdbflist WITH dbflist[1,1] ENDIF * Restore environment POP MENU _msysmenu SHOW WINDOW appgen ACTIVATE WINDOW appgen CLEAR READ RETURN FUNCTION putfontval PARAMETER m.value, m.code, m.i RETURN TRANFONT(m.value, m.code, WFONT(1,""), WFONT(2,""), WFONT(3,""), ; term(dbflist[m.i,m.thefont],1), VAL(term(dbflist[m.i,m.thefont],2)), ; term(dbflist[m.i,m.thefont],3) ) PROCEDURE arrexit * Exit without saving window positions PRIVATE m.i * Set exit flag for READ VALID--can't be PRIVATE m.arrexflg = .T. * Release all the application windows RELEASE WINDOW ctrl FOR m.i = 1 TO m.numareas IF !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' RELEASE WINDOW (dbflist[m.i,m.cstemnum]) ENDIF ENDFOR * Restore environment POP MENU _msysmenu SHOW WINDOW appgen ACTIVATE WINDOW appgen CLEAR READ RETURN FUNCTION haschild * Does the database at position "dbfnum" of DBFLIST have a child * table? parameter dbfnum PRIVATE m.dbfnum, m.i * See if another database has this one as its parent FOR m.i = 1 TO m.numareas IF ALLTRIM(dbflist[m.i,m.pdbfnum]) ; == ALLTRIM(dbflist[m.dbfnum,m.cstemnum]) RETURN .T. ENDIF ENDFOR RETURN .F. FUNCTION actwin * Activate window wind_name parameter wind_name PRIVATE ALL wind_name = UPPER(ALLTRIM(m.wind_name)) IF !EMPTY(m.wind_name) AND WEXIST(m.wind_name) ACTIVATE WINDOW (m.wind_name) ENDIF RETURN '' PROCEDURE errshow * Procedure to display an error message parameter m.messg, m.lineno PRIVATE ALL DO definewindow WITH 4, 70, "ALERT", 7 ACTIVATE WINDOW alert SET CURSOR OFF @ 0,0 CLEAR @ 1,0 SAY PADC(ALLTRIM(m.messg), WCOLS()) WAIT "" SET CURSOR ON RELEASE WINDOW alert RETURN PROCEDURE alert * Display an error message, automatically sizing the message window * as necessary. Semicolons in "strg" mean "new line". PARAMETERS strg PRIVATE ALL m.in_talk = SET('TALK') SET TALK OFF m.in_cons = SET('CONSOLE') m.numlines = OCCURS(';',m.strg) + 1 DIMENSION alert_arry[m.numlines] m.remain = m.strg m.maxlen = 0 FOR i = 1 TO m.numlines IF AT(';',m.remain) > 0 alert_arry[i] = SUBSTR(m.remain,1,AT(';',m.remain)-1) alert_arry[i] = CHRTRAN(alert_arry[i],';','') m.remain = SUBSTR(m.remain,AT(';',m.remain)+1) ELSE alert_arry[i] = m.remain m.remain = '' ENDIF IF LEN(alert_arry[i]) > SCOLS() - 6 alert_arry[i] = SUBSTR(alert_arry[i],1,SCOLS()-6) ENDIF IF LEN(alert_arry[i]) > m.maxlen m.maxlen = LEN(alert_arry[i]) ENDIF ENDFOR m.top_row = INT( (SROWS() - 4 - m.numlines) / 2) m.bot_row = m.top_row + 3 + m.numlines m.top_col = INT((SCOLS() - m.maxlen - 6) / 2) m.bot_col = m.top_col + m.maxlen + 6 DEFINE WINDOW alert FROM m.top_row,m.top_col TO m.bot_row,m.bot_col; DOUBLE COLOR SCHEME 7 ACTIVATE WINDOW alert FOR m.i = 1 TO m.numlines @ m.i,3 SAY PADC(alert_arry[m.i],m.maxlen) ENDFOR CLEAR TYPEAHEAD SET CONSOLE OFF m.keycode = 0 DO WHILE m.keycode = 0 m.keycode = INKEY(0,'HM') ENDDO SET CONSOLE ON RELEASE WINDOW alert IF m.in_talk = "ON" SET TALK ON ENDIF IF m.in_cons = "OFF" SET CONSOLE OFF ENDIF PROCEDURE apperror * Simple ON ERROR routine for FoxApp application PARAMETERS e_program,e_message,e_source,e_lineno,e_error ON ERROR m.e_source = ALLTRIM(m.e_source) DO CASE CASE m.e_error = 1707 && CDX not found. Ignore it. RETURN OTHERWISE DO alert WITH 'Line No.: '+ALLTRIM(STR(m.e_lineno,5))+';' ; +'Program: '+m.e_program +';' ; +' Error: '+m.e_message +';' ; +' Source: '+IIF(LEN(m.e_source)<50,; m.e_source,SUBSTR(m.e_source,1,50)+'...') DO close_up ENDCASE RETURN PROCEDURE appescape * Simple ON ESCAPE routine for FoxApp application PARAMETERS e_program,e_message,e_source,e_lineno,e_error WAIT WINDOW "Escape pressed. FoxApp is terminating." NOWAIT =INKEY(1.5) m.m_quitting = .T. * Enable the Window pad SET SKIP OF PAD _msm_windo OF _msysmenu .F. CLEAR READ DO close_up RETURN FUNCTION whatstyle PARAMETER m.stylenum IF NOT EMPTY(m.stylenum) DO CASE CASE m.stylenum = 1 RETURN "B" CASE m.stylenum = 2 RETURN "I" CASE m.stylenum = 3 RETURN "BI" ENDCASE ELSE RETURN "" ENDIF * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OOZZO m.addscx VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 2 ║ * ║ Variable: m.addscx ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 1 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0oozzo && m.addscx VALID #REGION 1 IF EMPTY(m.scxname) m.scxname = PUTFILE('Screen file name','','SCX') IF EMPTY(m.scxname) m.scxname = 'UNTITLED.SCX' ENDIF ELSE IF FILE(m.scxname) MODIFY SCREEN (m.scxname) ELSE DO createscx ENDIF ENDIF SHOW GETS RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP0HZ m.dbfname WHEN ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 9 ║ * ║ Variable: m.dbfname ║ * ║ Called By: WHEN Clause ║ * ║ Snippet Number: 2 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op0hz && m.dbfname WHEN #REGION 1 m.origname = m.dbfname m.dbfname = PADR(m.dbfname,m.apppathlen) m.skipdbfbut = .T. SHOW GETS SET CURSOR ON RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ DBFVALID m.dbfname VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 9 ║ * ║ Variable: m.dbfname ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 3 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION DBFVALID && m.dbfname VALID #REGION 1 m.dbfname = UPPER(ALLTRIM(m.dbfname)) IF m.dbfname == m.origname * do nothing--make sure comparison is "==" however. ELSE * Database name changed. Check resource file again. rsc_check = .F. ENDIF SET CURSOR OFF IF !EMPTY(m.dbfname) m.dbfname = FULLPATH(m.dbfname) ENDIF SHOW GETS DO CASE CASE EMPTY(juststem(m.dbfname)) AND !EMPTY(m.dbfname) WAIT WINDOW "Invalid database name." RETURN 0 CASE (EMPTY(justext(m.dbfname)) OR justext(m.dbfname) = 'DBF') ; AND (justfname(m.dbfname) >= 'A' AND justfname(m.dbfname) <= 'Z') ; AND LEN(justfname(m.dbfname))<=1 * Don't allow single letter database names--they get confused with areas WAIT WINDOW "Invalid database name." RETURN 0 CASE INLIST(justext(m.dbfname),'SCX','SCT','SPR') WAIT WINDOW "A screen file name is not allowed here." RETURN 0 CASE INLIST(justext(m.dbfname),'MNX','MNT','MPR') WAIT WINDOW "A menu file name is not allowed here." RETURN 0 OTHERWISE IF !('.' $ justfname(m.dbfname)) AND !EMPTY(m.dbfname) m.dbfname = forceext(m.dbfname,'DBF') ENDIF dbfname = UPPER(ALLTRIM(m.dbfname)) IF !EMPTY(m.dbfname) m.dbfalias = opendbf(m.dbfname) IF EMPTY(m.scxname) m.scxname = forceext(m.dbfname,'SCX') ENDIF ENDIF skipdbfbut = .F. * Poke this database into the first position of DBFLIST IF TYPE('DBFLIST') <> 'U' dbflist[1,m.cstemnum] = juststem(m.dbfname) ENDIF SHOW GETS RETURN .T. ENDCASE * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP103 m.adddbf VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 10 ║ * ║ Variable: m.adddbf ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 4 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op103 && m.adddbf VALID #REGION 1 IF EMPTY(m.dbfname) m.dbfname = PUTFILE('Database name:','','DBF') IF EMPTY(m.dbfname) RETURN .F. && don't do anything ENDIF ENDIF IF !FILE(m.dbfname) * This window controls the colors used by CREATE DEFINE WINDOW mywin FROM INT((srow()-20)/2),INT((scol()-71)/2); TO INT((srow()-20)/2)+19,INT((scol()-71)/2)+70 ; FLOAT CLOSE SHADOW MINIMIZE SYSTEM COLOR SCHEME 8 ACTIVATE WINDOW mywin NOSHOW CREATE (m.dbfname) DEACTIVATE WINDOW mywin RELEASE WINDOW mywin ELSE && this shouldn't be possible since the control should be disabled m.dname = opendbf(m.dbfname) IF !EMPTY(m.dname) MODIFY STRUCTURE ENDIF SHOW GET adddbf DISABLE SHOW GET moddbf ENABLE ENDIF SHOW GETS RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP18D m.moddbf VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 11 ║ * ║ Variable: m.moddbf ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 5 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op18d && m.moddbf VALID #REGION 1 IF !EMPTY(m.dbfname) IF !EMPTY(opendbf(m.dbfname)) MODIFY STRUCTURE ELSE SHOW GET moddbf DISABLE RETURN -2 ENDIF ENDIF RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP1FE m.Listdbf WHEN ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 12 ║ * ║ Variable: m.Listdbf ║ * ║ Called By: WHEN Clause ║ * ║ Snippet Number: 6 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op1fe && m.Listdbf WHEN #REGION 1 origname = ALLTRIM(UPPER(m.dbfname)) * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP1IK m.Listdbf VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 12 ║ * ║ Variable: m.Listdbf ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 7 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op1ik && m.Listdbf VALID #REGION 1 IF UPPER(ALLTRIM(m.dbfname)) <> UPPER(ALLTRIM(origname)) rsc_check = .F. ENDIF origname = m.dbfname CLOSE DATABASES dbfname = GETFILE('DBF','Database name:') IF EMPTY(m.dbfname) dbfname = m.origname ELSE =opendbf(m.dbfname) IF EMPTY(m.scxname) scxname = forceext(m.dbfname,'SCX') ENDIF ENDIF * Poke this database into the first position of DBFLIST IF TYPE('DBFLIST') <> 'U' dbflist[1,m.cstemnum] = juststem(m.dbfname) ENDIF SHOW GETS RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP1Q5 m.other VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 13 ║ * ║ Variable: m.other ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 8 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op1q5 && m.other VALID #REGION 1 DO opendbf WITH m.dbfname DO dbfselec.spr * Leave the main database open when through with picking subsidiary * databases. m.dbfalias = opendbf(m.dbfname) IF relateddbfs() SHOW GET arrange ENABLE ELSE SHOW GET arrange DISABLE ENDIF * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP1Y3 scxname WHEN ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 14 ║ * ║ Variable: scxname ║ * ║ Called By: WHEN Clause ║ * ║ Snippet Number: 9 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op1y3 && scxname WHEN #REGION 1 m.scxname = PADR(m.scxname,m.apppathlen) SHOW GET modscx DISABLE SHOW GET addscx DISABLE SET CURSOR ON RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP21X scxname VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 14 ║ * ║ Variable: scxname ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 10 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op21x && scxname VALID #REGION 1 SET CURSOR OFF IF !EMPTY(m.scxname) m.scxname = FULLPATH(m.scxname) ENDIF scxname = ALLTRIM(m.scxname) IF !('.' $ justfname(m.scxname)) AND !EMPTY(m.scxname) scxname = forceext(m.scxname,'SCX') ENDIF m.scxname = UPPER(m.scxname) DO CASE CASE EMPTY(juststem(m.scxname)) AND !EMPTY(m.scxname) WAIT WINDOW "Invalid screen name." RETURN 0 ENDCASE SHOW GETS * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP29J m.modscx WHEN ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 15 ║ * ║ Variable: m.modscx ║ * ║ Called By: WHEN Clause ║ * ║ Snippet Number: 11 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op29j && m.modscx WHEN #REGION 1 IF !FILE(m.scxname) WAIT WINDOW 'Creating screen file' NOWAIT DO createscx ENDIF RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP2D6 m.modscx VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 15 ║ * ║ Variable: m.modscx ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 12 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op2d6 && m.modscx VALID #REGION 1 IF FILE(m.scxname) AND !EMPTY(m.scxname) MODIFY SCREEN (m.scxname) ELSE WAIT WINDOW "Creating screen" NOWAIT DO createscx ENDIF SHOW GET addscx DISABLE SHOW GETS RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP2JN m.Listscx VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 16 ║ * ║ Variable: m.Listscx ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 13 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op2jn && m.Listscx VALID #REGION 1 origname = scxname scxname = GETFILE('SCX','Screen file name:') IF EMPTY(scxname) scxname = origname ENDIF SHOW GETS RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP2QF m.generate VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 17 ║ * ║ Variable: m.generate ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 14 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op2qf && m.generate VALID #REGION 1 #define fa_european 0 PRIVATE m.win_string, m.dname, m.quoted, m.sc_file, m.i, m.j IF m.generate = 1 IF EMPTY(m.dbfname) OR !FILE(m.dbfname) SHOW GETS RETURN -9 && bounce out of generate and return to the dbfname field ENDIF SET CURSOR OFF * Create a default input screen if the one the user specified doesn't * exist. IF EMPTY(m.scxname) m.scxname = forceext(m.dbfname,'SCX') ENDIF IF !FILE(m.scxname) DO createscx ENDIF CLOSE DATABASES m.scxname = UPPER(ALLTRIM(m.scxname)) m.dbfname = UPPER(ALLTRIM(m.dbfname)) m.mnuname = UPPER(ALLTRIM(m.mnuname)) SET CURSOR ON * Note the current directory and path m.c_path = SET('DEFAULT') + CURDIR() m.appfile = forceext(m.scxname,'APP') m.userapp_dir = justpath(m.scxname) SET DEFAULT TO (m.userapp_dir) m.mpoint = SET("POINT") SET POINT TO "." valid_name = .F. DO WHILE !valid_name m.appfile = PUTFILE('Name your application:',forceext(m.appfile,'APP'),'APP') DO CASE CASE UPPER(ALLTRIM(justfname(m.appfile))) == 'FOXAPP.APP' DO ALERT WITH "I named my program FoxApp. You have to name yours something else." m.valid_name = .F. OTHERWISE valid_name = .T. ENDCASE ENDDO IF EMPTY(m.appfile) && user pressed 'cancel'. Return to top screen. SHOW GETS ELSE && time to create the APP SET CONSOLE OFF * Store relations into resource file if needed IF TYPE("DBFLIST") <> "U" AND !m.rsc_stored AND m.storersc WAIT WINDOW "Saving database relations and window positions." NOWAIT DO putdbflist WITH dbflist[1,1] ENDIF m.win_string = "Generating application "+PROPER(juststem(m.appfile))+'.' WAIT WINDOW m.win_string NOWAIT HIDE WINDOW (WOUTPUT()) * tmfname is the name of the scaffolding program that pulls all the * FoxApp application modules together. tmfname = addbs(justpath(m.appfile))+'scaffold.prg' SET TEXTMERGE TO (m.tmfname) SET TEXTMERGE ON \\* ╓─────────────────────────────────────────────────────────╖ \* ║ ║ \* ║ <<DATE()>> scaffold.prg <<TIME()>> ║ \* ║ ║ \* ╟─────────────────────────────────────────────────────────╢ \* ║ ║ \* ║ Description: ║ \* ║ This program was automatically generated by FoxApp. ║ \* ║ ║ \* ╙─────────────────────────────────────────────────────────╜ \* \* To run this application, type DO <<UPPER(justfname(m.appfile))>> \* \* Set up runtime environment \CREATE VIEW appview \SET TALK OFF \PUSH MENU _msysmenu \PUSH KEY CLEAR \fxapp_error = ON('ERROR') \fxapp_esc = ON('ESCAPE') \SET SAFETY OFF \SAVE MACROS TO foxapp \SET SAFETY ON \SET DELETED ON \SET ESCAPE OFF \SET STEP OFF \SET ECHO OFF \SET PROCEDURE TO appproc.prg \SET CURSOR ON \m.set_point = SET("POINT") #IF fa_european \SET POINT TO "," #endif \CLOSE DATABASES \ON ERROR DO apperror WITH PROGRAM(),MESSAGE(),MESSAGE(1),LINENO(),ERROR() \ \IF _WINDOWS OR _MAC \ * Store current screen font and set it to MS Sans Serif. This ensures that \ * functions like SROWS() and SCOLS() return values we can use. \ m.scrn_font = WFONT(1,"") \ m.scrn_fsize = WFONT(2,"") \ m.scrn_fstyle = WFONT(3,"") \ MODIFY WINDOW SCREEN FONT "MS Sans Serif",8 STYLE "B" \ENDIF \ \IF TYPE("BAILOUT") <> "U" \ RELEASE bailout \ENDIF \IF TYPE("DBFNAME") <> "U" \ RELEASE dbfname \ENDIF \IF TYPE("WIN_NAME") <> "U" \ RELEASE win_name \ENDIF \IF TYPE("FILT_EXPR") <> "U" \ RELEASE filt_expr \ENDIF \IF TYPE("SRCHTERM") <> "U" \ RELEASE srchterm \ENDIF IF regen \regen = .T. && use SPR/MPR files instead of PRGs \EXTERNAL SCREEN getdest, getorder, appabout, ; \ appsrch, prtopts, prtsetup ELSE \regen = .F. \EXTERNAL PROCEDURE getdest, getorder, appabout, ; \ appsrch, prtopts, prtsetup ENDIF \ \PUBLIC bailout, dbfname, win_name, filt_expr, srchterm \m.bailout = .F. \m.dbfname = "<<m.dbfname>>" && database name \m.qprpath = justpath(m.dbfname) && query file path \m.filt_expr = "" && filter expression, if any \m.srchterm = SPACE(60) && search term \ \* Define constants for addressing DBFLIST \m.numareas = <<m.numareas>> \m.numcols = <<m.numcols>> \m.cstemnum = <<m.cstemnum>> \m.relstrnum = <<m.relstrnum>> \m.pfldnum = <<m.pfldnum>> \m.cfldnum = <<m.cfldnum>> \m.cdbfnum = <<m.cdbfnum>> \m.pdbfnum = <<m.pdbfnum>> \m.srownum = <<m.srownum>> \m.scolnum = <<m.scolnum>> \m.erownum = <<m.erownum>> \m.ecolnum = <<m.ecolnum>> \m.arranged = <<m.arranged>> \m.thefont = <<m.thefont>> \m.cascadenum = <<m.cascadenum>> \m.ctrlrow = <<INT(m.ctrlrow)>> \m.ctrlcol = <<INT(m.ctrlcol)>> \m.nextdbf = <<m.nextdbf>> \DO DefineDbf && define the DBFLIST array \ \ \* Summon the main application menu _mname = forceext(juststem(m.mnuname),IIF(regen,'MPR','PRG')) \DO <<_mname>> \ \* Open the main database \m.stem = juststem(m.dbfname) \IF USED(m.stem) \ SELECT (m.stem) \ELSE \ SELECT 0 \ IF !FILE(m.dbfname) \ m.dbfname = GETFILE('DBF','Please locate the '+JustStem(m.dbfname)+' database') \ ENDIF \ IF EMPTY(m.dbfname) OR !FILE(m.dbfname) \ DO alert WITH "The "+m.stem+" database could not be found." \ DO cleanup \ RETURN \ ELSE \ USE (m.dbfname) \ ENDIF \ENDIF \* Make sure the index exists and is hooked up \IF EMPTY(CDX(1)) \ IF !FILE(forceext(m.dbfname,'CDX')) \ DO invert WITH m.dbfname \ ELSE \ SET INDEX TO (forceext(m.dbfname,'CDX')) \ ENDIF \ENDIF \SET ORDER TO 1 \ \IF RECCOUNT() = 0 \ APPEND BLANK \ELSE \ IF RECCOUNT() < 10 \ COUNT FOR !DELETED() TO notdel \ IF m.notdel = 0 \ APPEND BLANK && all records were deleted! \ ENDIF \ ENDIF \ENDIF \GOTO TOP \ \CLEAR sc_file = LOWER(forceext(juststem(m.scxname),'SPR')) * Force user screen into a window and figure out its size m.vcoord = 0 m.hcoord = 0 IF FILE(m.scxname) SELECT 0 USE (m.scxname) ALIAS scrnfile LOCATE FOR objtype == 1 ; AND UPPER(ALLTRIM(platform)) == m.app_platform IF FOUND() * Make sure that user screen goes into a window IF EMPTY(scrnfile.name) win_msg = "Putting "+juststem(m.scxname)+" screen into window." WAIT WINDOW win_msg TIMEOUT 1 m.scrn_face = scrnfile.fontface m.scrn_size = scrnfile.fontsize m.scrn_style = scrnfile.fontstyle REPLACE scrnfile.name WITH juststem(m.appfile), ; scrnfile.style WITH 2, ; scrnfile.border WITH 1, ; scrnfile.center WITH .F., ; scrnfile.vpos WITH 1, ; scrnfile.hpos WITH 3 WAIT CLEAR ENDIF win_name = UPPER(ALLTRIM(scrnfile.name)) * Figure out where to put the screen and control panel IF relateddbfs() m.scrn_face = scrnfile.fontface m.scrn_size = scrnfile.fontsize m.scrn_style = scrnfile.fontstyle m.vcoord = m.ctrlrow && bottom of the screen m.hcoord = m.ctrlcol REPLACE scrnfile.center WITH .F. IF dbflist[1,m.arranged] = 'Y' REPLACE scrnfile.vpos WITH VAL(dbflist[1,m.srownum]) REPLACE scrnfile.hpos WITH VAL(dbflist[1,m.scolnum]) ELSE * Set default placement of browse windows if user hasn't arranged them FOR m.i = 2 to m.numareas * Position it below the previous browse or screen m.rnum = MIN(VAL(dbflist[m.i-1,m.srownum]); + VAL(dbflist[m.i-1,m.erownum]) + 2.5, SROWS()) dbflist[m.i,m.srownum] = ALLTRIM(STR(m.rnum,4)) * Center it horizontally m.cnum = (SCOLS() - VAL(dbflist[m.i,m.ecolnum])) / 2 dbflist[m.i,m.scolnum] = ALLTRIM(STR(m.cnum,4)) ENDFOR ENDIF ELSE * Use the screen coordinates in the SCX file to figure out * where to put the control panel IF scrnfile.center m.vcoord = (SROWS() + scrnfile.height) / 2 + 2 ELSE m.vcoord = scrnfile.vpos + scrnfile.height + 1 ENDIF m.hcoord = INT((SCOLS()-tranfont(73,6,"MS Sans Serif",8,"B"))/2) IF m.vcoord + 3 > SROWS() m.vcoord = SROWS()-3 ENDIF m.vcoord = INT(m.vcoord) m.hcoord = INT(m.hcoord) ENDIF REPLACE FLOAT WITH .T., CLOSE WITH .T. * Force a select of the dbfname database whenever the screen * is activated. This is necessary for the 1-to-many operations, * where clicking on a browse window will select some other * database. We have to reselect dbfname when the user clicks in * on the dbfname screen. This code stuffs a "SELECT dbfname" * into the activate snippet of the user screen, but only if there * isn't one there already. found_line = .F. * First scan for a previous FoxApp inserted line _MLINE = 0 m.numlines = MEMLINES(scrnfile.activate) m.i = 1 newact = "" DO WHILE m.i <= m.numlines m.theline = MLINE(scrnfile.activate,1,_MLINE) m.theline = ALLTRIM(UPPER(m.theline)) DO CASE CASE UPPER("SELECT ") $ theline AND "**FOXAPP**" $ theline * We found a previous FoxApp 2.5 insert. Is it the right one? * It might not be if the user renamed the database. IF UPPER("SELECT "+juststem(m.dbfname))+" " $ m.theline m.found_line = .T. m.newact = m.newact + CHR(13) + CHR(10) + m.theline ELSE * FoxApp statement, but the wrong one. Ignore it. ENDIF CASE "THE FOLLOWING LINE WAS ADDED BY FOXAPP" $ theline * FoxApp 2.0 insert. Drop this comment and the line that * follows it, unless the following line doesn't look like * one of mine. The insert should always be a SELECT * statement. m.theline = MLINE(scrnfile.activate,1,_MLINE) m.theline = ALLTRIM(UPPER(m.theline)) IF !("SELECT " $ m.theline) newact = m.newact + CHR(13) + CHR(10) + m.theline ENDIF OTHERWISE && not a FoxApp statement m.newact = m.newact + CHR(13) + CHR(10) + m.theline ENDCASE m.i = m.i + 1 ENDDO IF !m.found_line m.newact = m.newact ; + CHR(13) + CHR(10) + "SELECT "+juststem(m.dbfname)+" "+CHR(38)+CHR(38)+" Added by **FOXAPP**" ENDIF REPLACE scrnfile.activate WITH m.newact USE ENDIF ENDIF \m.win_name = "<<m.win_name>>" * This is the main loop to display the screen and any related browses. \DO WHILE !bailout \ * Set up any related databases \ DO setrelat \ * Display the main screen file \ DO <<m.sc_file>> \ENDDO \DO cleanup \RETURN \ \ \******************************************************************* \PROCEDURE cleanup \* Clean up after the application \SET PROCEDURE TO \CLOSE DATABASES \CLEAR WINDOWS \IF _WINDOWS OR _MAC \ MODIFY WINDOW SCREEN FONT m.scrn_font, m.scrn_fsize STYLE m.scrn_fstyle \ENDIF \IF SET('TALK') = 'ON' \ SET TALK OFF \ m.t_stat = 'ON' \ELSE \ m.t_stat = 'OFF' \ENDIF \SET TALK OFF \* Restore databases, indexes and environment \IF FILE("appview.vue") \ SET VIEW TO appview \ SET TALK OFF \ DELETE FILE appview.vue \ENDIF \IF FILE("foxapp.fky") \ RESTORE MACROS FROM foxapp \ DELETE FILE foxapp.fky \ENDIF \IF m.t_stat = "ON" \ SET TALK ON \ENDIF \SET POINT TO "&set_point" \POP KEY ALL \POP MENU _msysmenu \CLEAR PROGRAM \ \*Restore original error and escape routines \IF TYPE('fxapp_error') = 'C' \ ON ERROR &fxapp_error \ENDIF \ \IF TYPE('fxapp_esc') = 'C' \ ON ESCAPE &fxapp_esc \ENDIF \ \SET SAFETY ON \RELEASE m.bailout, m.dbfname, m.win_name, m.filt_expr, m.srchterm, m.skipvar, m.act3 \RELEASE dbflist \RETURN \ \******************************************************************* \PROCEDURE setrelat \* This procedure opens subsidiary databases (if any) and establishes \* the relations between the main database and the subsidiary \* databases. It will be empty if there are no subsidiary databases. IF TYPE("DBFLIST") <> "U" m.i = 2 DO WHILE !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' m.b_font = dbflist[m.i,m.thefont] \SELECT <<m.i>> tagname = SUBSTR(dbflist[m.i,m.cfldnum],AT('.',dbflist[m.i,m.cfldnum])+1) \dname = "<<dbflist[m.i,m.cdbfnum]>>" \IF !FILE(m.dname) \ m.dname = GETFILE('DBF','Please locate the '+Juststem(m.dname)+ ' database:') \ IF EMPTY(m.dname) OR !FILE(m.dname) \ DO alert WITH "The "+ALLTRIM(m.dname+" database could not be found.") \ DO cleanup \ CANCEL \ ELSE \ SET PATH TO (SET('PATH') + ';' + Justpath(m.dname)) \ dbflist[<<m.i>>,m.cdbfnum] = m.dname \ dbflist[<<m.i>>,m.cstemnum] = juststem(m.dname) \ ENDIF \ENDIF \USE (m.dname) ALIAS <<dbflist[m.i,m.cstemnum]>> ; \ ORDER TAG <<m.tagname>> \DEFINE WINDOW <<"W_"+dbflist[m.i,m.cstemnum]>> ; \ AT <<CHRTRAN(dbflist[m.i,m.srownum],",",".")>>, ; \ <<CHRTRAN(dbflist[m.i,m.scolnum],",",".")>> ; \ SIZE <<CHRTRAN(dbflist[m.i,m.erownum],",",".")>>, ; \ <<CHRTRAN(dbflist[m.i,m.ecolnum],",",".")>> ; \ FLOAT GROW ZOOM NOCLOSE MINIMIZE ; \ FONT "MS Sans Serif",8 ; \ STYLE "B" ; \ HALF ; \ COLOR SCHEME 10 \BROWSE LAST NOWAIT; \ WINDOW <<"W_"+dbflist[m.i,m.cstemnum]>> ; \ NOAPPEND ; \ <<IIF(m.nextdbf>1,"NODELETE","")>> ; \ COLOR SCHEME 10 m.i = m.i + 1 ENDDO m.i = 2 DO WHILE !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' \SELECT <<Juststem(dbflist[m.i,m.pdbfnum])>> \<<dbflist[m.i,m.relstrnum]>> ADDITIVE \ \* Restore the following line if you only want to see records in the \* parent file that have related records in the child file. \*SET FILTER TO FOUND('<<dbflist[m.i,m.cstemnum]>>') \ m.i = m.i + 1 ENDDO \SELECT <<Juststem(m.dbfname)>> ENDIF \RETURN \ \ \******************************************************************* \PROCEDURE definedbf \* Define the dbflist array \PUBLIC dbflist[m.numareas,m.numcols] FOR m.i = 1 TO m.numareas FOR m.j = 1 TO m.numcols IF TYPE("DBFLIST") <> "U" IF TYPE("dbflist[m.i,m.j]") = "C" \DBFLIST[<<m.i>>,<<m.j>>] = <<'"'+dbflist[m.i,m.j]+'"'>> ELSE \DBFLIST[<<m.i>>,<<m.j>>] = <<dbflist[m.i,m.j]>> ENDIF ELSE \DBFLIST[<<m.i>>,<<m.j>>] = '' ENDIF ENDFOR ENDFOR \ \ \******************************************************************* SET TEXTMERGE TO SET TEXTMERGE OFF SET CONSOLE ON SET NOTIFY OFF SET POINT TO &mpoint * Release the large dbflist array so that we don't run out of * memory and/or other system resources during project generation RELEASE dbflist m.appname = UPPER(ALLTRIM(m.appfile)) m.projname = forceext(m.appname,'PJX') * Compute the mimimum path between the project home directory * and the SCX file. We'll want the mimimum path stored in the * project file we are about to build so that the project will * be portable across directories. m.sc_name = SYS(2014,m.scxname,m.appname) m.p_path = justpath(m.projname) SET DEFAULT TO &p_path * Clear any existing project files. Start with a clean slate. IF FILE(m.projname) DELETE FILE (m.projname) ENDIF pjtname = forceext(m.projname,'PJT') IF FILE(m.pjtname) DELETE FILE (m.pjtname) ENDIF * One last check to make sure that the user didn't leave a * poisonous MPR hanging around. m.mpr_name = FULLPATH(addbs(justpath(m.projname))+'APPMENU.MPR') IF FILE(m.mpr_name) DELETE FILE &mpr_name m.mpx_name = FULLPATH(addbs(justpath(m.projname))+'APPMENU.MPX') IF FILE(m.mpx_name) DELETE FILE &mpx_name ENDIF ENDIF * Build the actual application project file and APP now SET MESSAGE TO "Building project" IF m.regen DO copypiece && copy FoxApp pieces to project directory BUILD PROJECT (m.projname) FROM ; (m.tmfname), ; (m.scxname), ; appproc.prg, ; appmenu.mnx, ; prtsetup.scx, ; getdest.scx, ; getorder.scx, ; appabout.scx, ; appsrch.scx ELSE BUILD PROJECT (m.projname) FROM ; (m.tmfname), ; (addbs(foxappdir)+'PRGS\appproc.prg'), ; (addbs(foxappdir)+'MENUS\appmenu.prg'), ; (addbs(foxappdir)+'SCREENS\prtsetup.prg'),; (addbs(foxappdir)+'SCREENS\getdest.prg'), ; (addbs(foxappdir)+'SCREENS\getorder.prg'),; (addbs(foxappdir)+'SCREENS\appabout.prg'),; (addbs(foxappdir)+'SCREENS\appsrch.prg'), ; (m.sc_name) ENDIF * Modify the new project to merge the FoxApp control panel * with the user screen (SCXNAME) into one screen set. SET MESSAGE TO "Adding control panel" DO mergectrl WITH m.projname, m.scxname, m.vcoord, m.hcoord SET MESSAGE TO "Building application" BUILD APP (m.appname) FROM (m.projname) * Set the default path back to what it was SET DEFAULT TO &c_path SET NOTIFY ON CLEAR READ ENDIF ENDIF RETURN .T. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP7BF m.advanced VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 18 ║ * ║ Variable: m.advanced ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 15 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op7bf && m.advanced VALID #REGION 1 DO advance.spr * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP7GH m.cancbut VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 19 ║ * ║ Variable: m.cancbut ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 16 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op7gh && m.cancbut VALID #REGION 1 quitting = .T. CLEAR READ * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP7LU m.arrange VALID ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX, Record Number: 20 ║ * ║ Variable: m.arrange ║ * ║ Called By: VALID Clause ║ * ║ Snippet Number: 17 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op7lu && m.arrange VALID #REGION 1 DO opendbf WITH m.dbfname PUSH MENU _msysmenu RELEASE arrexflg && causes upcoming Foundation read to terminate PUBLIC arrexflg m.arrexflg = .F. m.tree_up = WVISIBLE('treewind') HIDE WINDOW appgen IF WEXIST('dbfselec') HIDE WINDOW dbfselec ENDIF IF WEXIST('treewind') HIDE WINDOW treewind ENDIF DEFINE PAD a_save OF _msysmenu PROMPT "\<Save Arrangement!" KEY ALT+S,"" COLOR SCHEME 3 DEFINE PAD a_cancel OF _msysmenu PROMPT "\<Cancel!" KEY ALT+C,"" COLOR SCHEME 3 ON SELECTION PAD a_save OF _msysmenu DO arrsave ON SELECTION PAD a_cancel OF _msysmenu DO arrexit RELEASE PAD _MSM_SYSTM OF _msysmenu RELEASE PAD _MSM_FILE OF _msysmenu RELEASE PAD _MSM_EDIT OF _msysmenu RELEASE PAD _MSM_DATA OF _msysmenu RELEASE PAD _MSM_RECRD OF _msysmenu RELEASE PAD _MSM_PROG OF _msysmenu RELEASE PAD _MSM_WINDO OF _msysmenu RELEASE PAD RUN OF _msysmenu * Save the screen and start the arranging from a blank screen SAVE SCREEN TO arr_scrn ACTIVATE SCREEN CLEAR * See how wide and tall the actual control panel is. m.dname = addbs(m.foxappdir)+'screens\appctrl.scx' IF FILE(m.dname) m.in_area = SELECT() SELECT 0 USE (dname) AGAIN ALIAS ctrl LOCATE FOR platform = "WINDOWS" AND objtype = 1 IF FOUND() m.ctrl_width = ctrl.width m.ctrl_height = ctrl.height ELSE m.ctrl_width = 73.167 m.ctrl_height = 3.846 ENDIF USE SELECT (m.in_area) ELSE m.ctrl_width = 73.167 m.ctrl_height = 3.846 ENDIF m.ctrlrow = MAX(0,m.ctrlrow) m.ctrlcol = MAX(0,m.ctrlcol) * Define window for control panel DEFINE WINDOW ctrl ; AT m.ctrlrow,m.ctrlcol ; SIZE m.ctrl_height, m.ctrl_width ; TITLE "Control panel" ; HALF ; FONT "MS Sans Serif",8 ; STYLE "B" ; FLOAT NOZOOM NOCLOSE ACTIVATE WINDOW ctrl * Figure out how tall and wide the main database screen will be IF EMPTY(m.scxname) OR !FILE(m.scxname) * If a screen hasn't been defined yet, look at the database fields SELECT (dbflist[1,m.cstemnum]) m.maxlen = 0 m.maxheight = FCOUNT() + 4 m.maxcapt = 0 FOR m.i = 1 TO FCOUNT() m.maxlen = MAX(m.maxlen,FSIZE(FIELD(m.i))) && max field length m.maxcapt = MAX(m.maxcapt,LEN(FIELD(m.i))+2) && max field name length ENDFOR m.maxlen = m.maxlen + m.maxcapt + 4 && allow for borders m.sheight = m.maxheight m.swidth = m.maxlen ELSE && otherwise, look to the SCX itself SELECT 0 USE (m.scxname) AGAIN ALIAS fxscxnme LOCATE FOR platform = "WINDOWS" AND Objtype = 1 IF FOUND() m.dbf_fontface = fxscxnme.fontface m.dbf_fontsize = fxscxnme.fontsize m.dbf_fontstyle = fxscxnme.fontstyle m.sheight = fxscxnme.height m.swidth = fxscxnme.width ELSE WAIT WINDOW "FoxApp couldn't find any Windows records for this screen." m.sheight = 23 m.swidth = 74 ENDIF USE ENDIF * Determine position for main database window and define window DO CASE CASE UPPER(dbflist[1,m.arranged]) = "N" * No screen position yet defined for the main database. Center it, * unless there are lots of related databases. If there are, put * it closer to the top of the screen. IF m.nextdbf < 3 && just one database used in app m.start_row = MAX(INT(SROWS()/2-m.sheight/2),0) m.start_col = MAX(INT(SCOLS()/2-m.swidth/2),0) ELSE m.start_row = 1 m.start_col = MAX(INT(SCOLS()/2-m.swidth/2),0) ENDIF OTHERWISE && show it where the user put it last m.start_row = VAL(dbflist[1,m.srownum]) m.start_col = VAL(dbflist[1,m.scolnum]) ENDCASE m.start_row = MAX(0,m.start_row) m.start_col = MAX(0,m.start_col) * Define the blank window for the main database DEFINE WINDOW (dbflist[1,m.cstemnum]) ; AT m.start_row,m.start_col ; SIZE m.sheight,m.swidth ; TITLE dbflist[1,m.cstemnum] ; FONT "MS Sans Serif",8 ; STYLE "B" ; NOGROW FLOAT NOZOOM NOCLOSE ; COLOR SCHEME 1 * Define windows for child databases FOR m.i = 2 TO m.numareas IF !EMPTY(dbflist[m.i,m.cstemnum]) AND dbflist[m.i,m.cstemnum] <> '\' IF dbflist[m.i,m.arranged] = "N" * Try to place browse windows immediately beneath main screen m.win_height = 8 && minimum height of a BROWSE window IF m.start_row + m.sheight + (m.i-2)*(m.win_height+1) + 2 < SROWS() - 3 m.ws_row = m.start_row + m.sheight + (m.i-2)*(m.win_height+1) + 2 m.ws_col = 1 m.we_row = m.win_height m.we_col = 74 && width ELSE && put the browse windows in the upper left of the screen m.ws_row = m.i m.ws_col = m.i m.we_row = MIN(m.win_height,SROWS()-m.ws_row-1) && height m.we_col = 74 && width ENDIF ELSE m.fontstrg = dbflist[m.i,m.thefont] m.ws_row = VAL(dbflist[m.i,m.srownum]) m.ws_col = VAL(dbflist[m.i,m.scolnum]) m.we_row = VAL(dbflist[m.i,m.erownum]) m.we_col = VAL(dbflist[m.i,m.ecolnum]) ENDIF DEFINE WINDOW (dbflist[m.i,m.cstemnum]) ; AT m.ws_row,m.ws_col ; SIZE m.we_row,m.we_col ; SYSTEM ; TITLE dbflist[m.i,m.cstemnum] ; GROW FLOAT NOZOOM NOCLOSE ; HALF ; FONT "MS Sans Serif",8 ; STYLE "B" ; COLOR SCHEME 10 ACTIVATE WINDOW (dbflist[m.i,m.cstemnum]) ENDIF ENDFOR * Activate the main window and let user move things around. ACTIVATE WINDOW (dbflist[1,m.cstemnum]) * The foundation read terminates when the user selects "Save" or "Exit" from the menu READ VALID m.arrexflg IF m.tree_up AND WEXIST('treewind') SHOW WINDOW treewind ENDIF RELEASE arrexflg RESTORE SCREEN FROM arr_scrn * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ _QDL0OP90P Read Level Deactivate ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX ║ * ║ Called By: READ Statement ║ * ║ Snippet Number: 18 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION _qdl0op90p && Read Level Deactivate * * Deactivate Code from screen: APPSCX * #REGION 1 ?? CHR(7) RETURN .F. * ╓─────────────────────────────────────────────────────────╖ * ║ ║ * ║ SCRNUPD Read Level Show ║ * ║ ║ * ║ Function Origin: ║ * ║ ║ * ║ ║ * ║ From Platform: Windows ║ * ║ From Screen: APPSCX ║ * ║ Called By: READ Statement ║ * ║ Snippet Number: 19 ║ * ║ ║ * ╙─────────────────────────────────────────────────────────╜ * FUNCTION SCRNUPD && Read Level Show PRIVATE currwind STORE WOUTPUT() TO currwind * * Show Code from screen: APPSCX * #REGION 1 DO CASE CASE EMPTY(m.dbfname) OR skipdbfbut SHOW GET generate DISABLE SHOW GET other DISABLE SHOW GET adddbf DISABLE SHOW GET moddbf DISABLE CASE !FILE(m.dbfname) SHOW GET generate DISABLE SHOW GET other DISABLE SHOW GET adddbf ENABLE SHOW GET moddbf DISABLE OTHERWISE && everything is ok SHOW GET generate ENABLE SHOW GET other ENABLE SHOW GET adddbf DISABLE SHOW GET moddbf ENABLE ENDCASE DO CASE CASE EMPTY(m.scxname) SHOW GET addscx DISABLE SHOW GET modscx DISABLE SHOW GET arrange DISABLE CASE !FILE(m.scxname) SHOW GET addscx ENABLE SHOW GET modscx DISABLE SHOW GET arrange DISABLE OTHERWISE && everything is ok SHOW GET addscx DISABLE SHOW GET modscx ENABLE SHOW GET arrange ENABLE ENDCASE * See if there is a stored resource for this database in the current * resource file. This is in the SHOW snippet instead of in the * VALID for the "related" button since we want to get this information * even if the user never presses "related" in this session. IF !EMPTY(m.dbfname) AND !m.rsc_check AND m.retrieversc IF !EMPTY(ALIAS()) m.nextdbf = getdbflist(ALIAS()) * Only check the resource file once m.rsc_check = .T. ENDIF ENDIF IF relateddbfs() AND !EMPTY(m.scxname) AND FILE(m.scxname) SHOW GET arrange ENABLE ELSE SHOW GET arrange DISABLE ENDIF IF NOT EMPTY(currwind) ACTIVATE WINDOW (currwind) SAME ENDIF