Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a087 / 4.ddi / FXAPCODE.PR_ / FXAPCODE.bin

Wrap

Text File | 1994-02-02 | 85.8 KB | 2,801 lines

* FoxApp 2.6 -- FoxPro 2.6 application generator * Author: Walter J. Kennamer * Copyright 1994, Microsoft Corporation * Modified by: John L. Alden, Alden Anderson * ------------------------------------------------------------------------ * The following code was migrated here from the #SECTION 1 SETUP code in * the APPSCX screen. FxApCode.prg is now the Main file in the FoxApp * project, rather than appscx. PARAMETERS rscused, forceregen, fxapAppname PRIVATE ALL * 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 * fxapAppname C Memvar included when called from Catalog Manager. Name of * .app file is stored to this memvar before returning. * Record the status of TALK and SAFETY IF SET('TALK') = 'ON' SET TALK OFF m.app_talk = 'ON' ELSE m.app_talk = 'OFF' ENDIF DO CASE CASE _WINDOWS m.app_platform = "WINDOWS" m.g_dfltfface = "MS Sans Serif" m.g_dfltfsize = 8 m.g_dfltfstyle = "B" CASE _MAC m.app_platform = "MAC" m.g_dfltfface = "Geneva" m.g_dfltfsize = 10 m.g_dfltfstyle = "" CASE _DOS m.app_platform = "DOS" m.g_dfltfface = "FoxFont" m.g_dfltfsize = 10 m.g_dfltfstyle = "" OTHERWISE * WAIT WINDOW "This version of FoxApp only runs on Windows or the Macintosh." NOWAIT * RETURN ENDCASE m.app_safe = SET("SAFETY") SET SAFETY OFF m.app_dele = SET("DELETED") SET DELETED ON IF PARAMETERS() < 3 m.fxapAppname = "" && memvar will acquire name of .app file ENDIF 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 m.appfile = "" && this is the memvar that FoxApp uses to keep the && name of the .app that is generated. When called && by the Catlaog Manager, this value needs to be && assigned to the incoming parameter m.fxapAppname. DO APPSCX.SPR m.fxapAppname = alltrim(m.appfile) release appfile return *------------------------------------------------------------------ * Common procedure code for FoxApp, migrated here from the snippets * of the various screens. *------------------------------------------------------------------ *!***************************************************************** *! *! Procedure: CLOSE_UP *! *!***************************************************************** PROCEDURE close_up * Do closing housekeeping for FoxApp. SET TOPIC TO (mtopic) 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 POP KEY CLEAR PROGRAM m.scrn_font = WFONT(1,"") m.scrn_fsize = WFONT(2,"") m.scrn_fstyle = WFONT(3,"") IF ! _DOS MODIFY WINDOW SCREEN FONT m.scrn_font,m.scrn_fsize STYLE m.scrn_fstyle ENDIF * 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 && rem'd out by JLA return *!***************************************************************** *! *! Procedure: COPYPIECE *! *!***************************************************************** PROCEDURE copypiece * Copy FoxApp pieces to project directory IF _MAC fxpath = addbs(SYS(2027,foxappdir)) && probably C:\foxpro2\foxapp\ ELSE fxpath = addbs(foxappdir) ENDIF 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) *!***************************************************************** *! *! Procedure: PUTOUT *! *!***************************************************************** 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 *! *!***************************************************************** 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) *!***************************************************************** *! *! Procedure: VERSIONDATE *! *!***************************************************************** 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) *!***************************************************************** *! *! Procedure: TRIMZERO *! *!***************************************************************** FUNCTION trimzero * Trims ASCII 0 characters from strg PARAMETER m.strg RETURN CHRTRAN(m.strg,CHR(0),"") *!***************************************************************** *! *! Procedure: FORCEEXT *! *!***************************************************************** 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 *!***************************************************************** *! *! Procedure: DEFAULTEXT *! *!***************************************************************** 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 *!***************************************************************** *! *! Procedure: JUSTFNAME *! *!***************************************************************** 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 RAT(':',m.filname) > 0 m.filname = SUBSTR(m.filname,RAT(':',m.filname)+1,255) ENDIF RETURN ALLTRIM(UPPER(m.filname)) *!***************************************************************** *! *! Procedure: JUSTSTEM *! *!***************************************************************** 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 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,1,AT('.',m.filname)-1) ENDIF RETURN ALLTRIM(UPPER(m.filname)) *!***************************************************************** *! *! Procedure: JUSTEXT *! *!***************************************************************** 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) *!***************************************************************** *! *! Procedure: JUSTPATH *! *!***************************************************************** FUNCTION justpath * Return just the path name from "filname" PARAMETERS m.filname PRIVATE ALL m.filname = ALLTRIM(UPPER(m.filname)) m.pathsep = IIF(_MAC,":", "\") IF _MAC m.found_it = .F. m.maxchar = max(RAT("\", m.filname), RAT(":", m.filname)) IF m.maxchar > 0 m.filname = SUBSTR(m.filname,1,m.maxchar) 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 ENDIF ELSE IF m.pathsep $ filname m.filname = SUBSTR(m.filname,1,RAT(m.pathsep,m.filname)) IF RIGHT(m.filname,1) = m.pathsep AND LEN(m.filname) > 1 ; AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> m.pathsep m.filname = SUBSTR(m.filname,1,LEN(m.filname)-1) ENDIF RETURN m.filname ENDIF ENDIF RETURN '' *!***************************************************************** *! *! Procedure: ADDBS *! *!***************************************************************** 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 + IIF(_MAC,':','\') ENDIF RETURN m.pathname *!***************************************************************** *! *! Function: ADDCOLON *! *!***************************************************************** FUNCTION Addcolon PARAMETER m.strg PRIVATE m.retval * If strg is the name of the current disk, add a colon to it. This * function is used mainly by SET DEFAULT TO statements, where we have * to have the colon. IF UPPER(m.strg)+":" == UPPER(SET("DEFAULT")) m.retval = m.strg + ":" ELSE m.retval = m.strg ENDIF RETURN m.retval *!***************************************************************** *! *! Function: TERM *! *!***************************************************************** 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 *! *!***************************************************************** 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 = makealias(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 !INLIST(TYPE(m.fldname),"M","G","P") 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 *! *!***************************************************************** 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 IF _MAC m.ctrl_scx = SYS(2027, m.ctrl_scx) ENDIF IF FILE(m.ctrl_scx) SELECT 0 USE (m.ctrl_scx) AGAIN ALIAS ctrlscx REPLACE ctrlscx.hpos WITH m.ctrl_x, ctrlscx.vpos WITH m.ctrl_y USE ELSE WAIT WINDOW "Could not find "+m.ctrl_scx RETURN ENDIF * Quit now if the project file is hiding. IF !FILE(m.pjxname) RETURN ENDIF * The lower case comparisons won't work if COLLATE <> MACHINE m.mcollate = SET("COLLATE") SET COLLATE TO "MACHINE" IF USED(makealias(juststem(m.pjxname))) * Open it again with the 'pjxfile' alias. m.sname = makealias(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) ; +"MAC "+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 SET COLLATE TO "&mcollate" ELSE * This means that something went badly wrong during BUILD PROJECT WAIT WINDOW "FoxApp could not complete this application." SET DEFAULT TO (c_path) SET COLLATE TO "&mcollate" DO close_up CANCEL ENDIF USE SELECT (in_area) *!***************************************************************** *! *! Procedure: INITDBFLIST *! *!***************************************************************** 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 *!***************************************************************** *! *! Procedure: OPENDBF *! *!***************************************************************** FUNCTION opendbf * Open a DBF and return the alias, or blanks if the database could * not be opened. PARAMETERS fname PRIVATE fname, stem, thealias IF FILE(m.fname) m.stem = juststem(m.fname) m.thealias = LEFT(m.stem,10) m.thealias = CHRTRAN(m.thealias, ' ', '_') IF USED(m.thealias) SELECT (m.thealias) 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 *! *!***************************************************************** 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 IF _MAC WAIT WINDOW "Creating screen "+SYS(2027,m.s_name) NOWAIT ELSE WAIT WINDOW "Creating screen "+m.s_name NOWAIT ENDIF 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(my_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(my_srows()/2-height/2),0) m.start_col = MAX(INT(my_scols()/2-width/2),0) ELSE m.start_row = 1 m.start_col = MAX(INT(my_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(my_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 = getplat() * 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 = getplat() 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 makealias(juststem(m.scxname)), ; fxscxname.style WITH 2,; fxscxname.border WITH 1,; fxscxname.tag WITH '" '+makealias(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 *!***************************************************************** *! *! Procedure: FILATTR *! *!***************************************************************** 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 '' *!***************************************************************** *! *! Procedure: RELATEDDBFS *! *!***************************************************************** FUNCTION relateddbfs * RETURN T if related DBF files have been defined through FoxApp RETURN m.nextdbf > 2 *!***************************************************************** *! *! Procedure: GETDBFLIST *! *!***************************************************************** 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] = makealias(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] = makealias(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 *!***************************************************************** *! *! Procedure: PUTDBFLIST *! *!***************************************************************** 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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 IF WEXIST('CTRL') m.ctrlrow = WLROW('CTRL') m.ctrlcol = WLCOL('CTRL') RELEASE WINDOW ctrl ENDIF * 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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 getplat DO CASE CASE _MAC RETURN "MAC" CASE _WINDOWS RETURN "WINDOWS" CASE _DOS RETURN "DOS" CASE _UNIX RETURN "UNIX" OTHERWISE RETURN "UNKNOWN" ENDCASE *!***************************************************************** *! *! Procedure: HASCHILD *! *!***************************************************************** 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. *!***************************************************************** *! *! Procedure: ACTWIN *! *!***************************************************************** 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 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 *! *!***************************************************************** PROCEDURE alert * Display an error message, automatically sizing the message window * as necessary. Semicolons in "strg" mean "new line". PARAMETERS strg PRIVATE m.in_talk, m.numlines, m.i, m.remain, m.in_cons 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]) > my_scols() - 6 alert_arry[i] = SUBSTR(alert_arry[i],1,my_scols()-6) ENDIF IF LEN(alert_arry[i]) > m.maxlen m.maxlen = LEN(alert_arry[i]) ENDIF ENDFOR m.top_row = INT( (my_srows() - 4 - m.numlines) / 2) m.bot_row = m.top_row + 3 + m.numlines m.top_col = INT((my_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 *! *!***************************************************************** 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 *! *!***************************************************************** 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 *! *! Called by: ALLCHARTOGRAPHIC (procedure in TRANSPRT.PRG) *! : FILLININFO (procedure in TRANSPRT.PRG) *! : ITEMSINBOXES (procedure in TRANSPRT.PRG) *! : GETWINDFONT (procedure in TRANSPRT.PRG) *! : ADJHEIGHTANDWIDTH (procedure in TRANSPRT.PRG) *! *!***************************************************************************** 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 *!***************************************************************************** *! *! Procedure: FNADDQUOTES *! *!***************************************************************************** FUNCTION fnaddquotes PARAMETER m.fname DO CASE CASE INLIST(LEFT(m.fname,1), "'", '"', '[') RETURN m.fname CASE AT('"', m.fname) = 0 RETURN '"' + m.fname + '"' CASE AT("'", m.fname) = 0 RETURN "'" + m.fname + "'" CASE AT("[", m.fname) = 0 AND AT("]", m.fname) = 0 RETURN "[" + m.fname + "]" OTHERWISE RETURN m.fname ENDCASE *!***************************************************************************** *! *! Procedure: MAKEALIAS *! *!***************************************************************************** FUNCTION makealias PARAMETER filname m.filname = UPPER(ALLTRIM(m.filname)) m.filname = CHRTRAN(m.filname, ' ', '_') m.filname = LEFT(m.filname, 10) RETURN m.filname *!***************************************************************************** *! *! Procedure: ISWIZ *! *!***************************************************************************** FUNCTION iswiz PARAMETER strg * Was this screen created by a FoxPro wizard? RETURN IIF("*~ WIZARDSCREEN" $ UPPER(m.strg), .T., .F.) *!***************************************************************************** *! *! Function: MY_SROWS *! *!***************************************************************************** FUNCTION my_srows IF _MAC RETURN (SYSMETRIC(2) - SYSMETRIC(20) ) / FONTMETRIC(1,m.g_dfltfface, m.g_dfltfsize, m.g_dfltfstyle) ELSE RETURN SROWS() ENDIF *!***************************************************************************** *! *! Function: MY_SCOLS *! *!***************************************************************************** FUNCTION my_scols DO CASE CASE _MAC RETURN SYSMETRIC(1) / FONTMETRIC(6,m.g_dfltfface, m.g_dfltfsize, m.g_dfltfstyle) CASE _DOS RETURN SCOLS() OTHERWISE RETURN SROWS() && ??! Original code...is this intended? -jla ENDCASE PROCEDURE DbfNameWhen * WHEN clause from m.dbfname get in appscx *------------------------------------------------------------------ m.origname = m.dbfname IF !EMPTY(m.dbfname) AND _MAC m.dbfname = SYS(2027, m.dbfname) ENDIF m.dbfname = PADR(m.dbfname,m.apppathlen) m.skipdbfbut = .T. SHOW GETS SET CURSOR ON RETURN .T. PROCEDURE DbfNameValid * VALID clause from m.dbfname get in appscx *------------------------------------------------------------------ * #NAME dbfvalid 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) IF _MAC m.dbfname = SYS(2027,FULLPATH(m.dbfname)) ELSE m.dbfname = FULLPATH(m.dbfname) ENDIF 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] = makealias(juststem(m.dbfname)) ENDIF SHOW GETS RETURN .T. ENDCASE PROCEDURE ListDbfValid * VALID clause from m.Listdbf button in appscx *------------------------------------------------------------------ IF UPPER(ALLTRIM(m.dbfname)) <> UPPER(ALLTRIM(m.origname)) m.rsc_check = .F. ENDIF m.origname = m.dbfname CLOSE DATABASES m.dbfname = GETFILE('DBF','Database name:') IF EMPTY(m.dbfname) m.dbfname = m.origname ELSE IF _MAC m.dbfname = SYS(2027, m.dbfname) ENDIF =opendbf(m.dbfname) IF EMPTY(m.scxname) IF _MAC m.scxname = SYS(2027,forceext(m.dbfname,'SCX')) ELSE m.scxname = forceext(m.dbfname,'SCX') ENDIF ENDIF ENDIF * Poke this database into the first position of DBFLIST IF TYPE('DBFLIST') <> 'U' dbflist[1,m.cstemnum] = makealias(juststem(m.dbfname)) ENDIF SHOW GETS RETURN .T. PROCEDURE AddDbfValid * VALID clause from m.adddbf button in appscx *------------------------------------------------------------------ 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. PROCEDURE ModDbfValid * VALID clause from m.moddbf button in appscx *------------------------------------------------------------------ IF !EMPTY(m.dbfname) IF !EMPTY(opendbf(m.dbfname)) MODIFY STRUCTURE ELSE SHOW GET moddbf DISABLE RETURN -2 ENDIF ENDIF RETURN .T. PROCEDURE OtherValid * VALID clause from m.other button in appscx ("Related...") *------------------------------------------------------------------ IF _MAC AND !FILE(m.dbfname) WAIT WINDOW "Could not find "+TRIM(m.dbfname) NOWAIT RETURN ENDIF 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 PROCEDURE ScxNameWhen * WHEN clause from m.scxname get in appscx *------------------------------------------------------------------ m.scxname = PADR(m.scxname,m.apppathlen) SHOW GET modscx DISABLE SHOW GET addscx DISABLE SET CURSOR ON RETURN .T. PROCEDURE ScxNameValid * VALID clause from m.scxname get in appscx *------------------------------------------------------------------ SET CURSOR OFF m.scxname = UPPER(ALLTRIM(m.scxname)) IF !EMPTY(m.scxname) m.scxname = FULLPATH(m.scxname) ENDIF scxname = ALLTRIM(m.scxname) IF !('.' $ justfname(m.scxname)) AND !EMPTY(justfname(m.scxname)) scxname = forceext(m.scxname,'SCX') ENDIF m.scxname = UPPER(m.scxname) DO CASE CASE !EMPTY(m.scxname) AND EMPTY(juststem(m.scxname)) WAIT WINDOW "Invalid screen name." RETURN 0 ENDCASE IF _MAC m.scxname = SYS(2027, m.scxname) ENDIF SHOW GETS PROCEDURE ListScxValid * VALID clause from m.Listscx button in appscx *------------------------------------------------------------------ m.origname = m.scxname m.scxname = GETFILE('SCX','Screen file name:') IF EMPTY(scxname) m.scxname = m.origname ELSE IF _MAC m.scxname = SYS(2027, m.scxname) ENDIF ENDIF SHOW GETS RETURN .T. PROCEDURE AddScxValid * VALID clause from m.addscx button in appscx *------------------------------------------------------------------ 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. PROCEDURE ModScxWhen * WHEN clause from m.modscx button in appscx *------------------------------------------------------------------ IF !FILE(m.scxname) WAIT WINDOW 'Creating screen file' NOWAIT DO createscx ENDIF RETURN .T. PROCEDURE ModScxValid * VALID clause from m.modscx button in appscx *------------------------------------------------------------------ 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. PROCEDURE ArrangeValid * VALID clause from m.arrange button in appscx *------------------------------------------------------------------ PRIVATE m.wiz_screen, m.tree_up, m.arrexflg, m.in_area, m.maxcapt, m.maxlen, m.maxheight, m.start_row, ; m.start_col, m.sheight, m.swidth, m.ws_col, m.ws_row, m.we_row, m.we_col 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 m.wiz_screen = .F. m.in_area = SELECT() SELECT 0 USE (m.scxname) AGAIN LOCATE FOR platform = m.app_platform AND objtype = 1 IF FOUND() m.wiz_screen = iswiz(setupcode) ENDIF USE SELECT (m.in_area) IF !m.wiz_screen * 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 = m.app_platform AND objtype = 1 IF FOUND() m.ctrl_width = ctrl.width m.ctrl_height = ctrl.height ELSE m.ctrl_width = 73.167 && go with default values then 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 m.g_dfltfface, m.g_dfltfsize ; STYLE m.g_dfltfstyle ; FLOAT NOZOOM NOCLOSE ACTIVATE WINDOW ctrl ENDIF * 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 = m.app_platform 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 m.platformword = IIF(_MAC,"Macintosh", IIF(_DOS,"DOS","Windows")) WAIT WINDOW "FoxApp couldn't find any " + m.platformword + ; " records for this screen." * WAIT WINDOW "FoxApp couldn't find any " + ; * IIF(_MAC,"Macintosh","Windows" + " records for this screen.") m.sheight = 21 && was 23, changed by J. Alden for DOS port 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(my_srows()/2-m.sheight/2),0) m.start_col = MAX(INT(my_scols()/2-m.swidth/2),0) ELSE m.start_row = 1 m.start_col = MAX(INT(my_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 m.g_dfltfface, m.g_dfltfsize ; STYLE m.g_dfltfstyle ; 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 < my_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,my_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 m.g_dfltfface, m.g_dfltfsize ; STYLE m.g_dfltfstyle ; 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, ws_row, ws_col, we_row, we_col, i, tree_up, win_height, sheight, swidth RESTORE SCREEN FROM arr_scrn PROCEDURE GenerateValid * VALID clause from m.generate button in appscx *------------------------------------------------------------------ #define fa_european 0 PRIVATE m.win_string, m.dname, m.quoted, m.sc_file, m.i, m.j, m.wizscreen, m.dest, m.msg, ; m.c_path, m.userapp_dir, m.valid_name m.wizscreen = .F. && assume it isn't a screen wizard screen--they have their own ctrl panel IF m.generate = 1 IF !FILE(m.dbfname) OR EMPTY(m.dbfname) DO CASE CASE EMPTY(m.dbfname) m.msg = "No table name entered. Enter one and try again." m.dest = -9 CASE !FILE(m.dbfname) m.msg = "Could not find "+justfname(m.dbfname) m.dest = -9 OTHERWISE * This code shouldn't exectute m.dest = -9 m.msg = "Error generating application" ENDCASE WAIT WINDOW m.msg NOWAIT SHOW GETS RETURN m.dest && 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 = addcolon(justpath(m.scxname)) SET DEFAULT TO (m.userapp_dir) RELEASE m.userapp_dir m.mpoint = SET("POINT") SET POINT TO "." m.valid_name = .F. DO WHILE !m.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 m.valid_name = .T. ENDCASE ENDDO RELEASE m.valid_name 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()) RELEASE m.win_string * tmfname is the name of the scaffolding program that pulls all the * FoxApp application modules together. m.tmfname = addbs(justpath(m.appfile))+'scaffold.prg' SET TEXTMERGE TO (m.tmfname) SET TEXTMERGE ON IF _MAC OR _WINDOWS \\* +---------------------------------------------------------+ \* | | \* | <<DATE()>> scaffold.prg <<TIME()>> | \* | | \* +---------------------------------------------------------+ \* | | \* | Description: | \* | This program was automatically generated by FoxApp. | \* | | \* +---------------------------------------------------------+ ELSE \\* ╓─────────────────────────────────────────────────────────╖ \* ║ ║ \* ║ <<DATE()>> scaffold.prg <<TIME()>> ║ \* ║ ║ \* ╟─────────────────────────────────────────────────────────╢ \* ║ ║ \* ║ Description: ║ \* ║ This program was automatically generated by FoxApp. ║ \* ║ ║ \* ╙─────────────────────────────────────────────────────────╜ ENDIF \* \* 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 something reasonable. \ m.scrn_font = WFONT(1,"") \ m.scrn_fsize = WFONT(2,"") \ m.scrn_fstyle = WFONT(3,"") \ MODIFY WINDOW SCREEN FONT "<<m.g_dfltfface>>",<<m.g_dfltfsize>> STYLE "<<m.g_dfltfstyle>>" \ENDIF \ \IF TYPE("BAILOUT") <> "U" \ RELEASE m.bailout \ENDIF \IF TYPE("DBFNAME") <> "U" \ RELEASE m.dbfname \ENDIF \IF TYPE("WIN_NAME") <> "U" \ RELEASE m.win_name \ENDIF \IF TYPE("FILT_EXPR") <> "U" \ RELEASE m.filt_expr \ENDIF \IF TYPE("SRCHTERM") <> "U" \ RELEASE m.srchterm \ENDIF IF m.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, wiz_screen, 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 \m.win_name = "" && name assigned below \m.wiz_screen = .F. && assume false for now \ \* 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 m._mname = FNAddQuotes(forceext(juststem(m.mnuname),IIF(regen,'MPR','PRG'))) \DO <<m._mname>> \ \* Open the main database \m.stem = makealias(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 m.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 COUNT FOR UPPER(ALLTRIM(platform)) == m.app_platform TO m.platcnt IF platcnt = 0 m.platword = IIF(_MAC,"Macintosh",IIF(_DOS,"DOS","Windows")) WAIT WINDOW m.scxname + " does not contain " ; + m.platword + " records." * WAIT WINDOW m.scxname + " does not contain " ; * +IIF(_MAC,"Macintosh","Windows")+" records." RETURN .F. ENDIF LOCATE FOR objtype == 1 ; AND UPPER(ALLTRIM(platform)) == m.app_platform IF FOUND() m.win_name = makealias(UPPER(ALLTRIM(scrnfile.name))) m.wizscreen = iswiz(setupcode) IF !m.wizscreen * 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 * 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, my_srows()) dbflist[m.i,m.srownum] = ALLTRIM(STR(m.rnum,4)) * Center it horizontally m.cnum = (my_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 = (my_srows() + scrnfile.height) / 2 + 3 ELSE m.vcoord = scrnfile.vpos + scrnfile.height + 1 ENDIF m.hcoord = INT((my_scols()-tranfont(73,6,m.g_dfltfface,m.g_dfltfsize,m.g_dfltfstyle))/2) IF m.vcoord + 3 > my_srows() m.vcoord = my_srows()-3 ENDIF 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. m.found_line = .F. * First scan for a previous FoxApp inserted line _MLINE = 0 m.numlines = MEMLINES(scrnfile.activate) m.i = 1 m.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 "+makealias(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) m.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 "+makealias(juststem(m.dbfname))+" "+CHR(38)+CHR(38)+" Added by **FOXAPP**" ENDIF REPLACE scrnfile.activate WITH m.newact USE ENDIF && not wizard screen ELSE * This should never happen WAIT WINDOW "Screen heading record could not be found." RETURN .F. ENDIF ELSE * This should never happen WAIT WINDOW "Screen could not be opened." RETURN .F. ENDIF RELEASE newact, found_line, theline, i, numlines \m.win_name = "<<m.win_name>>" \m.wiz_screen = <<IIF(m.wizscreen,".T.", ".F.")>> * This is the main loop to display the screen and any related browses. \DO WHILE !m.bailout \ * Set up any related databases \ DO setrelat \ * Display the main screen file \ DO <<FNAddQuotes(m.sc_file)>> \ * Make sure nothing closed the database unexpectedly \ m.stem = makealias(juststem(m.dbfname)) \ IF !USED(m.stem) \ SELECT 0 \ USE (m.dbfname) \ ENDIF \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.wiz_screen, 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] = makealias(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 "<<m.g_dfltfface>>",<<m.g_dfltfsize>> ; \ STYLE "<<m.g_dfltfstyle>>" ; \ 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 <<makealias(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 <<makealias(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, i, j, m.b_font 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 = addcolon(justpath(m.projname)) SET DEFAULT TO (m.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 RELEASE mpr_name, mpx_name * 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 prg1 = addbs(m.foxappdir)+'PRGS\appproc.prg' prg2 = addbs(m.foxappdir)+'MENUS\appmenu.prg' prg3 = addbs(m.foxappdir)+'SCREENS\prtsetup.prg' prg4 = addbs(m.foxappdir)+'SCREENS\getdest.prg' prg5 = addbs(m.foxappdir)+'SCREENS\getorder.prg' prg6 = addbs(m.foxappdir)+'SCREENS\appabout.prg' prg7 = addbs(m.foxappdir)+'SCREENS\appsrch.prg' BUILD PROJECT (m.projname) FROM ; (m.tmfname), ; (prg1), ; (prg2), ; (prg3),; (prg4), ; (prg5),; (prg6),; (prg7), ; (m.sc_name) ENDIF IF !m.wizscreen * 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 ENDIF 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. PROCEDURE AppScxShow * READ-level SHOW clause for appscx screen *------------------------------------------------------------------ DO CASE CASE EMPTY(m.dbfname) OR skipdbfbut IF !_MAC SHOW GET generate DISABLE SHOW GET other DISABLE ENDIF SHOW GET adddbf DISABLE SHOW GET moddbf DISABLE CASE !FILE(m.dbfname) IF !_MAC SHOW GET generate DISABLE SHOW GET other DISABLE ENDIF 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 PROCEDURE BrResValid * Browse FoxApp resource file entries * VALID clause for from Browse Resources button on Advance screen *------------------------------------------------------------------ PRIVATE m.in_area, m.in_del m.in_del = SET("DELETED") SET DELETED ON m.in_area = SELECT() SELECT 0 USE (SYS(2005)) AGAIN ALIAS app_rsc DO CASE CASE _MAC DEFINE WINDOW rsc_brow FROM 4,my_scols()/2-35/2 TO 14,my_scols()/2+35/2 ; CLOSE GROW FLOAT ZOOM MINIMIZE ; TITLE "FoxApp Resource File Entries" ; FONT "Monaco",9 CASE _DOS DEFINE WINDOW rsc_brow FROM 4,my_scols()/2-35/2 TO 14,my_scols()/2+35/2 ; TITLE "FoxApp Resource File Entries" ; SYSTEM ; FLOAT ; CLOSE ; SHADOW ; MINIMIZE OTHERWISE DEFINE WINDOW rsc_brow FROM 4,my_scols()/2-35/2 TO 14,my_scols()/2+35/2 ; CLOSE GROW FLOAT ZOOM MINIMIZE ; TITLE "FoxApp Resource File Entries" ; FONT "FoxFont",9 ENDCASE BROWSE LAST ; WINDOW rsc_brow ; FIELD app_rsc.type, app_rsc.id, app_rsc.name ; FOR UPPER(ALLTRIM(app_rsc.type)) == UPPER(ALLTRIM(m.rsctype)) USE RELEASE WINDOW rsc_brow SELECT (m.in_area) SET DELETED &in_del return