Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a108 / 15.ddi / FXAPCODE.PR_ / FXAPCODE.bin

Wrap

Text File | 1994-03-10 | 92.4 KB | 3,060 lines

* FoxApp 2.6 -- FoxPro 2.6 application generator * Author: Walter J. Kennamer * Copyright 1994, Microsoft Corporation * Adapted for wizards and localization 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 EXTERNAL PROCEDURE MSGBOX * For debugging, set this memvar to .t. * 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. * --- Localization -------------------------------------------------------------- * Note on localization: Function "versiondate" in this file uses English strings when looking * in the string returned by VERS(1) for the month of the FoxPro build. As of 2/4/94 this * string was not being localized, so the English strings were left in place. If in * future builds VERS() is localized, then these strings ought to be lifted up into this * localization section and turned into #DEFINE's. #DEFINE C_BADPLAT "This version of FoxApp only runs on Windows, DOS or Macintosh." #DEFINE C_SOURCE1 "FoxApp source files must be available to build projects." #DEFINE C_LOCSRC "Please locate the FOXAPP.SRC file:" #DEFINE C_SOURCE2 "FoxApp cannot build a full project without its source files." #DEFINE C_INDEXFOR "Indexing for " #DEFINE C_INDEXON "Indexing on " #DEFINE C_ISCOMP " is complete!" #DEFINE C_NOFIND "Could not find " #DEFINE C_FAILAPP "FoxApp could not complete this application." #DEFINE C_LOCDBF "Please locate the database" #DEFINE C_SCXCREA1 "Creating screen " #DEFINE C_SCXMADE "Screen has been created." #DEFINE C_DBFNOOPN "Database could not be opened." #DEFINE C_WHERE "Where is " #DEFINE C_NOTFND " could not be found!" #DEFINE C_RSCRO "Resource file is read-only. Not updated." #DEFINE C_RSCREC "Existing resource record is read-only. Not updated." #DEFINE C_WINPOS "Saving window positions." #DEFINE C_ERRLINE "Line No.: " #DEFINE C_ERRPRG "Program: " #DEFINE C_ERRERR " Error: " #DEFINE C_ERRSRC " Source: " #DEFINE C_ESCPRESS "Escape pressed. FoxApp is terminating." #DEFINE C_BADDBF "Invalid database name." #DEFINE C_SCXNAME "A screen file name is not allowed here." #DEFINE C_MNXNAME "A menu file name is not allowed here." #DEFINE C_DBFPMT "Database name:" #DEFINE C_BADSCX "Invalid screen name." #DEFINE C_SCXPMT "Screen file name:" #DEFINE C_SCXCREA2 "Creating screen file" #DEFINE C_SAVEARR "\<Save Arrangement!" KEY ALT+S && Note keyboard shortcuts #DEFINE C_CANCPMT "\<Cancel!" KEY ALT+C && may change with localization #DEFINE C_CTRLTITL "Control panel" #DEFINE C_NOREC1 "FoxApp couldn't find any " #DEFINE C_NOREC2 " records for this screen." #DEFINE C_NOTABLE "No table name entered. Enter one and try again." #DEFINE C_ERRGEN "Error generating application" #DEFINE C_NAMEPMT "Name your application:" #DEFINE C_SAMENAME "I named my program FoxApp. You have to name yours something else." #DEFINE C_SAVDBWIN "Saving database relations and window positions." #DEFINE C_GENMSG "Generating application " #DEFINE C_TMDESC | Description: #DEFINE C_TMHEAD | This program was automatically generated by FoxApp. #DEFINE C_TMRUN To run this application, type DO #DEFINE C_TMENV Set up runtime environment #DEFINE C_TMFONT Store current screen font and set it to something reasonable. #DEFINE C_TMDESCD ║ Description: #DEFINE C_TMHEADD ║ This program was automatically generated by FoxApp. #DEFINE C_TGETMENU Summon the main application menu #DEFINE C_TOPENDBF Open the main database #DEFINE C_TPLSLOC "Please locate the " #DEFINE C_TDBF " database" #DEFINE C_TTHE "The " #DEFINE C_TDBNOTFD " database could not be found." #DEFINE C_TCHKIDX Make sure the index exists and is hooked up #DEFINE C_TRECDEL all records were deleted! #DEFINE C_NOTCONT " does not contain " #DEFINE C_RECORDS " records." #DEFINE C_PUTTING "Putting " #DEFINE C_SCXINWIN " screen into window." #DEFINE C_FACOMM "THE FOLLOWING LINE WAS ADDED BY FOXAPP" #DEFINE C_NOSCXHD "Screen heading record could not be found." #DEFINE C_NOSCXOPN "Screen could not be opened." #DEFINE C_TDBSET Set up any related databases #DEFINE C_TSCXDISP Display the main screen file #DEFINE C_TNODBCLS Make sure nothing closed the database unexpectedly #DEFINE C_TCLEANUP Clean up after the application #DEFINE C_TRESTENV Restore databases, indexes and environment #DEFINE C_RESTERR Restore original error and escape routines #DEFINE C_TSREL1 This procedure opens subsidiary databases (if any) and establishes #DEFINE C_TSREL2 the relations between the main database and the subsidiary #DEFINE C_TSREL3 databases. It will be empty if there are no subsidiary databases. #DEFINE C_TDBF2 " database:" #DEFINE C_TSEEREC1 Restore the following line if you only want to see records in the #DEFINE C_TSEEREC2 parent file that have related records in the child file. #DEFINE C_TDEFARR Define the dbflist array #DEFINE C_BLDPJX "Building project" #DEFINE C_CTRLMSG "Adding control panel" #DEFINE C_BLDAPP "Building application" #DEFINE C_RSCTITLE "FoxApp Resource File Entries" #DEFINE C_NOTADBF "The file you have chosen is not a valid table." #DEFINE C_NOLIB " is not available." #DEFINE C_LOCATE "Please locate " #DEFINE C_ONELTR "Table name must be longer than one character." * ------------------------------------------------------------------------------- * Used in FA_Alert() function. #DEFINE C_WINLIB "FOXTOOLS.FLL" #DEFINE C_OK 0 #DEFINE C_YESNO 4 #DEFINE C_YES 6 #DEFINE C_ICONQ 32 #DEFINE C_ICONEXCL 48 * 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" m.libfile = C_WINLIB m.libext = "FLL" CASE _MAC m.app_platform = "MAC" m.g_dfltfface = "Geneva" m.g_dfltfsize = 10 m.g_dfltfstyle = "" m.libfile = "" CASE _DOS m.app_platform = "DOS" m.g_dfltfface = "FoxFont" m.g_dfltfsize = 10 m.g_dfltfstyle = "" m.libfile = "" m.libext = "PLB" OTHERWISE WAIT WINDOW C_BADPLAT NOWAIT RETURN ENDCASE m.fa_libavail = .t. m.fa_loadlib = len(m.libfile) > 0 if m.fa_loadlib if ! m.libfile $ SET("LIBRARY",1) m.fa_libavail = .f. IF !FILE(SYS(2004)+m.libfile) m.templib=LOCFILE(m.libfile,m.libext,C_LOCATE+m.libfile+':') IF EMPTY(m.templib) WAIT WINDOW m.libfile + C_NOLIB return ELSE m.libfile = m.templib ENDIF ELSE m.libfile = sys(2004)+m.libfile ENDIF SET LIBRARY TO (m.libfile) ADDITIVE ENDIF endif m.app_safe = SET("SAFETY") SET SAFETY OFF m.app_dele = SET("DELETED") SET DELETED ON m.fa_fldset = SET("FIELDS") && on or off m.fa_fldscope = SET("FIELDS",2) && local or global SET FIELDS OFF SET FIELDS GLOBAL 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 track the && name of the .app that is generated. When called && by the Catlaog Manager, this value will be && assigned to the incoming parameter m.fxapAppname. m.GenSuccess = .f. && flag indicating successful generation of FoxApp app. DO APPSCX.SPR m.fxapAppname = iif(m.GenSuccess, alltrim(m.appfile), "") release appfile if m.libfile <> "" and ! m.fa_libavail && library was not in use originally RELEASE LIBRARY (m.libfile) endif set fields &fa_fldset set fields &fa_fldscope return *--------------------------------------------------------------------- * Common procedure code for FoxApp, migrated here from screen snippets *--------------------------------------------------------------------- *!***************************************************************** *! *! Procedure: CLOSE_UP *! *!***************************************************************** PROCEDURE close_up * Do closing housekeeping for FoxApp. SET TOPIC TO (mtopic) RELEASE scxname, dbfname, invname, cdxname, repname, tmfname, ; bailout, 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 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 C_SOURCE1 NOWAIT m.targfile = GETFILE('SRC',C_LOCSRC) IF EMPTY(m.targfile) DO alert WITH C_SOURCE2 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 C_INDEXON + 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 C_INDEXFOR + m.fstem + C_ISCOMP 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 LOCATE FOR ALLTRIM(platform) = ALLTRIM(m.app_platform) AND ; objtype = 1 IF FOUND() REPLACE ctrlscx.hpos WITH m.ctrl_x, ctrlscx.vpos WITH m.ctrl_y ENDIF USE ELSE = FA_Alert(C_NOFIND + 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 = FA_Alert(C_FAILAPP) 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, olderror 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',C_LOCDBF) IF EMPTY(m.fname) RETURN '' ELSE m.olderror = ON("ERROR") ON ERROR DO TEMPERR USE (m.fname) ON ERROR &olderror 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 C_SCXCREA1 +SYS(2027,m.s_name) NOWAIT ELSE WAIT WINDOW C_SCXCREA1 + 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 locate for alltrim(platform) = m.app_platform and objtype = 1 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 C_SCXMADE NOWAIT ELSE DO errshow WITH C_DBFNOOPN,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)) m.ctrlrow = MIN(my_srows()-3,m.ctrlrow) m.ctrlcol = MIN(my_scols()-3,m.ctrlcol) 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',; C_WHERE +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]+ C_NOTFND 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 C_RSCRO 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 C_RSCREC 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 C_WINPOS 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 C_ERRLINE + ALLTRIM(STR(m.e_lineno,5))+';' ; +C_ERRPRG + m.e_program +';' ; +C_ERRERR + m.e_message +';' ; +C_ERRSRC + 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 C_ESCPRESS 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 SCOLS() 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) 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 IF ! chktblname(m.dbfname) RETURN 0 ELSE 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 * 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. ENDIF PROCEDURE CHKTBLNAME PARAMETER TNAME DO CASE CASE EMPTY(juststem(m.tname)) AND !EMPTY(m.tname) = FA_Alert(C_BADDBF) RETURN .f. CASE (EMPTY(justext(m.tname)) OR justext(m.tname) = 'DBF') ; AND (justfname(m.tname) >= 'A' AND justfname(m.tname) <= 'Z') ; AND LEN(juststem(m.tname))<=1 * Don't allow single letter database names--they get confused with areas = FA_Alert(C_ONELTR) RETURN .f. CASE INLIST(justext(m.tname),'SCX','SCT','SPR') = FA_Alert(C_SCXNAME) RETURN .f. CASE INLIST(justext(m.tname),'MNX','MNT','MPR') = FA_Alert(C_MNXNAME) RETURN .f. OTHERWISE RETURN .t. ENDCASE PROCEDURE ListDbfValid * VALID clause from m.Listdbf button in appscx *------------------------------------------------------------------ PRIVATE m.testdbf IF UPPER(ALLTRIM(m.dbfname)) <> UPPER(ALLTRIM(m.origname)) m.rsc_check = .F. ENDIF m.origname = m.dbfname CLOSE DATABASES m.dbfname = GETFILE('DBF',C_DBFPMT) IF EMPTY(m.dbfname) m.dbfname = m.origname ELSE IF _MAC m.dbfname = SYS(2027, m.dbfname) ENDIF m.testdbf = opendbf(m.dbfname) if len(alltrim(m.testdbf)) = 0 m.dbfname = m.origname return endif if ! chktblname(m.dbfname) _curobj = objnum(dbfname) return endif 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(C_DBFPMT,'','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 C_NOFIND + 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() AND !EMPTY(m.scxname) AND FILE(m.scxname) 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) IF ! FILE(m.scxname) SHOW GET addscx ENABLE SHOW GET modscx DISABLE ELSE SHOW GET addscx DISABLE SHOW GET modscx ENABLE ENDIF 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)) = FA_Alert(C_BADSCX) 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',C_SCXPMT) 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(C_SCXPMT,'','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 C_SCXCREA2 NOWAIT DO createscx ENDIF RETURN .T. PROCEDURE ModScxValid * VALID clause from m.modscx button in appscx *------------------------------------------------------------------ IF FILE(m.scxname) AND !EMPTY(m.scxname) if used("scrnfile") use in scrnfile endif MODIFY SCREEN (m.scxname) ELSE WAIT WINDOW C_SCXCREA1 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 C_SAVEARR,"" COLOR SCHEME 3 DEFINE PAD a_cancel OF _msysmenu PROMPT C_CANCPMT,"" 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.ctrlrow = MIN(my_srows()-3,m.ctrlrow) m.ctrlcol = MAX(0,m.ctrlcol) m.ctrlcol = MIN(my_scols()-7,m.ctrlcol) * Define window for control panel DEFINE WINDOW ctrl ; AT m.ctrlrow,m.ctrlcol ; SIZE m.ctrl_height, m.ctrl_width ; TITLE C_CTRLTITL ; HALF ; FONT m.g_dfltfface, m.g_dfltfsize ; STYLE m.g_dfltfstyle ; FLOAT NOZOOM NOCLOSE ACTIVATE WINDOW ctrl ENDIF m.sfontface = m.g_dfltfface m.sfontsize = m.g_dfltfsize m.sfontstyle = m.g_dfltfstyle * 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.sfontface = fxscxnme.fontface m.sfontsize = fxscxnme.fontsize m.sfontstyle = num2style(fxscxnme.fontstyle) m.sheight = fxscxnme.height m.swidth = fxscxnme.width ELSE m.platformword = IIF(_MAC,"Macintosh", IIF(_DOS,"DOS","Windows")) = FA_Alert(C_NOREC1 + m.platformword + C_NOREC2) m.sheight = 21 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.sfontface, m.sfontsize ; STYLE m.sfontstyle ; 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 RETURN FUNCTION num2style * Translate a font style number to its equivalent string representation PARAMETER m.num PRIVATE m.i, m.strg, m.pow, m.stylechars, m.outstrg m.strg = "" * These are the style characters. Their position in the string matches the bit * position in the num byte. m.stylechars = "BIUOSCE-" * Look at each of the bits in the num byte FOR m.i = 8 TO 1 STEP -1 m.pow = ROUND(2^(i-1),0) IF m.num >= m.pow m.strg = m.strg + SUBSTR(stylechars,m.i,1) ENDIF m.num = m.num % m.pow ENDFOR * Now reverse the string so that style codes appear in the traditional order m.outstrg = "" FOR m.i = 1 TO LEN(m.strg) m.outstrg = m.outstrg + SUBSTR(m.strg,LEN(m.strg)+1-m.i,1) ENDFOR RETURN m.outstrg 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 = C_NOTABLE m.dest = -9 CASE !FILE(m.dbfname) m.msg = C_NOFIND + justfname(m.dbfname) m.dest = -9 OTHERWISE * This code shouldn't exectute m.dest = -9 m.msg = C_ERRGEN 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(C_NAMEPMT,forceext(m.appfile,'APP'),'APP') DO CASE CASE UPPER(ALLTRIM(justfname(m.appfile))) == 'FOXAPP.APP' DO ALERT WITH C_SAMENAME 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 C_SAVDBWIN NOWAIT DO putdbflist WITH dbflist[1,1] ENDIF m.win_string = C_GENMSG +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()>> | \* | | \* +---------------------------------------------------------+ \* | | \* C_TMDESC | \* C_TMHEAD | \* | | \* +---------------------------------------------------------+ ELSE \\* ╓─────────────────────────────────────────────────────────╖ \* ║ ║ \* ║ <<DATE()>> scaffold.prg <<TIME()>> ║ \* ║ ║ \* ╟─────────────────────────────────────────────────────────╢ \* ║ ║ \* C_TMDESCD ║ \* C_TMHEADD ║ \* ║ ║ \* ╙─────────────────────────────────────────────────────────╜ ENDIF \* \* C_TMRUN <<UPPER(justfname(m.appfile))>> \* \* C_TMENV \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 \ * C_TMFONT \ 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 \ \ \* C_TGETMENU m._mname = FNAddQuotes(forceext(juststem(m.mnuname),IIF(regen,'MPR','PRG'))) \DO <<m._mname>> \ \* C_TOPENDBF \m.stem = makealias(juststem(m.dbfname)) \IF USED(m.stem) \ SELECT (m.stem) \ELSE \ SELECT 0 \ IF !FILE(m.dbfname) \ m.dbfname = GETFILE('DBF',C_TPLSLOC+JustStem(m.dbfname)+C_TDBF) \ ENDIF \ IF EMPTY(m.dbfname) OR !FILE(m.dbfname) \ DO alert WITH C_TTHE +m.stem+C_TDBNOTFD \ DO cleanup \ RETURN \ ELSE \ USE (m.dbfname) \ ENDIF \ENDIF \* C_TCHKIDX \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 && C_TRECDEL \ 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")) = FA_Alert(m.scxname + C_NOTCONT + m.platword + C_RECORDS) SET TEXTMERGE TO SET TEXTMERGE OFF SET CONSOLE ON SET NOTIFY OFF ACTIVATE WINDOW (WOUTPUT()) 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 = C_PUTTING +juststem(m.scxname)+C_SCXINWIN 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 C_FACOMM $ 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 = FA_Alert(C_NOSCXHD) RETURN .F. ENDIF ELSE * This should never happen = FA_Alert(C_NOSCXOPN) 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 \ * C_TDBSET \ DO setrelat \ * C_TSCXDISP \ DO <<FNAddQuotes(m.sc_file)>> \ * C_TNODBCLS \ m.stem = makealias(juststem(m.dbfname)) \ IF !USED(m.stem) \ SELECT 0 \ USE (m.dbfname) \ ENDIF \ENDDO \DO cleanup \RETURN \ \ \******************************************************************* \PROCEDURE cleanup \* C_TCLEANUP \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 \* C_TRESTENV \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 \ \* C_RESTERR \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 \* C_TSREL1 \* C_TSREL2 \* C_TSREL3 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',C_TPLSLOC+Juststem(m.dname)+ C_TDBF2) \ IF EMPTY(m.dname) OR !FILE(m.dname) \ DO alert WITH C_TTHE +ALLTRIM(m.dname+C_TDBNOTFD) \ 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 NOWAIT; \ PREFERENCE <<"P_"+dbflist[m.i,m.cstemnum]>> ; \ 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 \ \* C_TSEEREC1 \* C_TSEEREC2 \*SET FILTER TO FOUND('<<dbflist[m.i,m.cstemnum]>>') \ m.i = m.i + 1 ENDDO \SELECT <<makealias(Juststem(m.dbfname))>> ENDIF \RETURN \ \ \******************************************************************* \PROCEDURE definedbf \* C_TDEFARR \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 C_BLDPJX 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 C_CTRLMSG DO mergectrl WITH m.projname, m.scxname, m.vcoord, m.hcoord ENDIF SET MESSAGE TO C_BLDAPP 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 m.GenSuccess = .t. RETURN .T. PROCEDURE AppScxShow * READ-level SHOW clause for appscx screen *------------------------------------------------------------------ DO CASE CASE EMPTY(m.dbfname) 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 SHOW GET generate 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 C_RSCTITLE ; FONT "Monaco",9 CASE _DOS DEFINE WINDOW rsc_brow FROM 4,my_scols()/2-35/2 TO 14,my_scols()/2+35/2 ; TITLE C_RSCTITLE ; 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 C_RSCTITLE ; 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 PROCEDURE TEMPERR * Trap specific error if dbf not selected = FA_Alert(C_NOTADBF) return PROCEDURE FA_Alert * Alert dialog that uses MSGBOX() in foxtools.fll, if that library * was loaded. * ---------------------------------------------------------------- PARAMETER fa_emsg,fa_alerttype if ! fa_loadlib wait window fa_emsg return endif IF TYPE('fa_emsg')<>'C' return ENDIF IF EMPTY(fa_alerttype) OR TYPE('fa_alerttype')#'N' fa_alerttype=0 ENDIF * for evaluating macro substitutions IF AT('&',fa_emsg)>0 fa_emsg='&fa_emsg' ENDIF IF fa_alerttype=1 RETURN msgbox(m.fa_emsg,"FoxApp",C_YESNO+C_ICONQ)=C_YES ELSE RETURN msgbox(m.fa_emsg,"FoxApp",C_OK+C_ICONEXCL) ENDIF