Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a070 / 3.ddi / FOXPRO / TEMPLGEN / AP1PROC.INC < prev next >

Wrap

Text File | 1988-05-05 | 11.3 KB | 542 lines

<<* APPPROC.INC *>> <<procedure GenProcStandard>> <<string alpha>> <<begin>> PROCEDURE SayRec * ---"SayRec" is used by the EDIT program and PROCEDURE DoCONT. * DO StatLine WITH RECNO(),DELETED() DO {fileprefix}_SAYS * * ---If you are calling "SayRec" from more than one * ---application, you may wish to replace the above * ---line with a DO CASE structure, as follows: * * * ---"appnum" is the application ID number. * DO CASE * CASE appnum = 1 * DO AP1_SAYS * CASE appnum = 2 * DO AP2_SAYS * ENDCASE * RETURN PROCEDURE GetKey PARAMETER choice,keychars PRIVATE keycode choice = "*" DO WHILE .NOT. (choice $ keychars) keycode = INKEY() IF keycode > 0 choice = UPPER(CHR(keycode)) ENDIF * ---A keyfilter can be implemented here, as follows: * * * ---FROM: {{}F1} ^leftarrow ^rightarrow * * ---INTO: "H" leftarrow rightarrow * fromkeys = CHR(28) + CHR(26) + CHR(2) * intokeys = "H" + CHR(19) + CHR(4) * choice = SUBSTR( "*"+intokeys,AT(choice,fromkeys) + 1,1 ) ENDDO RETURN <<if ismultipage>> PROCEDURE Page PARAMETER pageno,pagedir,PageMax pageno = pageno + pagedir DO CASE CASE pageno < 1 * ---Circle to last page. pageno = PageMax CASE pageno > PageMax * ---Circle to first page. pageno = 1 ENDCASE RETURN <<endif>> PROCEDURE StatLine PARAMETER recnum,IsDeleted <<GenColor( 1,'STATUS' )>> @ 0, 8 SAY SUBSTR( STR( recnum + 1000000,7 ),2 ) <<if ismultipage>> @ 0,23 SAY STR( pageno,2 ) <<endif>> <<if ismultials>> @ 0,29 SAY "< >" @ 0,30 SAY SUBSTR( DBFname,1,AT( ".",DBFname )-1 ) <<endif>> IF IsDeleted @ 0,50 SAY "*DELETED*" ELSE @ 0,50 SAY " " ENDIF RETURN PROCEDURE SayEOF PARAMETER row,oldrecnum <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR IF EOF() @ row,0 SAY "END-OF-FILE encountered" ELSE @ row,0 SAY "BEGINNING-OF-FILE encountered" ENDIF WAIT @ row,0 CLEAR IF oldrecnum > 0 GOTO oldrecnum ENDIF RETURN PROCEDURE SayLine PARAMETER row,strg <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR @ row,0 SAY strg RETURN PROCEDURE GotoRec PARAMETER row,recnum,lastrecnum recnum = 0 <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR @ row+1,17 SAY "{ 1 to " @ row+1,24 SAY SUBSTR( STR( lastrecnum + 1000000,7 ),2 ) + " } + {Return}" @ row,0 SAY "Enter RECORD number" GET recnum; PICTURE "@Z 9999999" RANGE 0,lastrecnum READ @ row,0 CLEAR IF recnum > 0 GOTO recnum ENDIF RETURN PROCEDURE DoGOTO PARAMETER row,recnum,lastrecnum recnum = 0 <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR <<if LiteBar>> menuchoice = 4 @ row,0 SAY "GOTO:" @ row, 7 PROMPT "Top" @ row,12 PROMPT "Bottom" @ row,20 PROMPT "Number" @ row,28 PROMPT "Return" MENU TO menuchoice choice = SUBSTR( Returnkey+"TBR"+Returnkey,menuchoice + 1,1 ) <<else>> <<if Bracketed>> @ row,0 SAY "GOTO: {T}op {B}ottom {R}ecord# {Return} " <<else>> <<*Simple*>> @ row,0 SAY "GOTO: (T)op (B)ottom (R)ecord# <Return> " <<endif>> DO GetKey WITH choice,"TBR"+Returnkey <<endif>> @ row,0 CLEAR DO CASE CASE choice = Returnkey RETURN CASE choice = "T" GOTO TOP recnum = RECNO() CASE choice = "B" GOTO BOTTOM recnum = RECNO() CASE choice = "R" DO GotoRec WITH row,recnum,lastrecnum ENDCASE RETURN PROCEDURE DoLOCATE PARAMETER row,expr PRIVATE oldrecnum oldrecnum = RECNO() DO SayLine WITH row,"Locating..." LOCATE FOR &expr IF EOF() DO SayEOF WITH row,oldrecnum ELSE @ row,0 CLEAR @ row,0 SAY "LOCATE FOR" GET expr CLEAR GETS DO DoCONT WITH row ENDIF RETURN PROCEDURE DoCONT PARAMETER row PRIVATE oldrecnum choice = "Y" DO WHILE choice = "Y" .AND. .NOT. EOF() oldrecnum = RECNO() DO SayRec DO SayLine WITH row+1,"Continue? (y/n)" DO GetKey WITH choice,"YN"+Returnkey @ row+1,0 CLEAR IF choice = "Y" CONTINUE ENDIF ENDDO IF EOF() DO SayEOF WITH row,oldrecnum ENDIF RETURN <<end>> <<*GenProcStandard*>> <<# procedure GenFuncStandard begin select all select fields on ("VLU(" $ upper(fldval)) if (fldtotal > 0) #>> PROCEDURE VLU PARAMETER lookals,lookexp,lookmsg PRIVATE origals,notvalid origals = STR( SELECT(),2 ) SELECT &lookals SEEK lookexp notvalid = EOF() IF notvalid * ---Could not find <exp> in <LOOKUP> file. DO SayLine WITH PromptRow,lookmsg WAIT @ PromptRow,0 CLEAR ENDIF SELECT &origals RETURN .NOT. notvalid <<endif>> <<select all fields>> <<end GenFuncStandard>> <<procedure GenExecSeek>> <<string fixedkey>> <<begin>> <<fixedkey := fixautomem(ndxkey)>> <<if ndxtyp = 'C'>> expr = TRIM( {fixedkey} ) IF "" <> expr SEEK expr ENDIF <<elsif ndxtyp = 'N'>> expr = {fixedkey} IF expr <> 0 SEEK expr ENDIF <<else>> <<*DATE type*>> expr = {fixedkey} IF DTOC(expr) <> " / / " SEEK expr ENDIF <<endif>> <<end GenExecSeek>> <<# procedure GenKeySeek string pic,firstpart,keyfld integer count begin select all fields select fields on (fldtyp $ 'CDN') and (fldals <> 'M') forall (upper(fldnam) $ upper(ndxkey)) and (forcount <= 2) keyfld := fixfldnam #>> <<if fldtyp = 'C'>> {keyfld} = SPACE({fldwid}) <<elsif fldtyp = 'N'>> {keyfld} = 0.0 <<else>> {keyfld} = CTOD(" / / ") <<endif>> <<# endfor count := 0 forall (upper(fldnam) $ upper(ndxkey)) and (forcount <= 2) count := count + 1 keyfld := fixfldnam if forcount = 1 firstpart := '@ row, 0 SAY "Enter ' + fldnam + '"' else firstpart := '@ row+1,0 SAY " ' + fldnam + '"' endif <<*---PICTURE---*>> pic := fldpic if fldtyp = 'N' <<*Force PICTURE on Numerics*>> pic := replicate( '9',fldwid ) if flddec pic[ fldwid-flddec ] := '.' endif endif #>> <<if pic>> {firstpart} GET {keyfld} PICTURE {"}{pic}{"} <<else>> {firstpart} GET {keyfld} <<endif>> <<endfor>> <<if count = 0>> * ---Key expression: {ndxkey} DO SayLine WITH row,"Key expression does not match database file." WAIT @ row,0 CLEAR <<else>> READ <<GenExecSeek>> <<endif>> <<select all fields>> <<end GenKeySeek>> <<procedure GenSingleSEEK>> <<string alpha,fixedkey>> <<begin>> <<alpha := chr( dbfcount + 64 )>> <<if ismultials>> PROCEDURE {fileprefix}_{alpha}SEE <<else>> PROCEDURE {fileprefix}_SEEK <<endif>> PARAMETER row PRIVATE expr <<if not ismultials>> IF NdxOrder = "0" RETURN ENDIF <<endif>> <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR DO CASE <<forall indexes>> CASE NdxOrder = {"}{ndxcount}{"} <<GenKeySeek>> <<endfor>> ENDCASE RETURN <<end GenSingleSEEK>> <<procedure GenMultiSEEK>> <<string alpha>> <<begin>> PROCEDURE {fileprefix}_SEEK PARAMETER row IF NdxOrder = "0" RETURN ENDIF DO CASE <<forall databases>> CASE dbfarea = {"}{dbfcount}{"} <<alpha := chr( dbfcount + 64 )>> <<if ndxtotal > 0>> DO {fileprefix}_{alpha}SEE WITH row <<else>> * ---<none>. <<endif>> <<endfor>> ENDCASE RETURN <<end>> <<*GenMultiSEEK*>> <<procedure GenSetIndex( procname : string )>> <<string keydisp,keyopts,ndxnames>> <<integer width>> <<begin>> PROCEDURE {procname} PARAMETER row,ndxchoice <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR <<# forall indexes filespec( ndxnam,fpath,fname,fext ) keydisp := keydisp + ' ' + str( ndxcount ) + '-' + fname + ' ' keyopts := keyopts + str( ndxcount ) endfor #>> @ row,0 SAY {"}SET INDEX: {keydisp}{"} DO GetKey WITH ndxchoice,{"}{keyopts}{"}+Returnkey IF ndxchoice = Returnkey RETURN ENDIF NdxOrder = ndxchoice SET ORDER TO &NdxOrder RETURN <<end>> <<*GenSetIndex*>> <<procedure GenSetNdxs>> <<string alpha,keydisp,keyopts,ndxnames>> <<begin>> PROCEDURE {fileprefix}_NDXS PARAMETER row,ndxchoice DO CASE <<forall databases>> CASE dbfarea = {"}{dbfcount}{"} <<alpha := chr( dbfcount + 64 )>> <<if ndxtotal > 1>> DO {fileprefix}_{alpha}NDX WITH row,ndxchoice <<elsif ndxtotal = 1>> * ---Only one index. ndxchoice = "1" <<else>> * ---No indexes. <<endif>> <<endfor>> ENDCASE RETURN <<end>> <<*GenSetNdxs*>> <<procedure GenSetFile>> <<string keydisp1,keyopts1,keydisp2,keyopts2,ndxnames>> <<integer width>> <<begin>> PROCEDURE {fileprefix}_FILE PARAMETER row,dbfchoice <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR <<# forall databases filespec( dbfnam,fpath,fname,fext ) if forcount <= 5 keydisp1 := keydisp1 + ' ' + str( dbfcount ) + '-' + fname + ' ' keyopts1 := keyopts1 + str( dbfcount ) else keydisp2 := keydisp2 + ' ' + str( dbfcount ) + '-' + fname + ' ' keyopts2 := keyopts2 + str( dbfcount ) endif endfor select all databases #>> <<if dbftotal <= 5>> @ row,0 SAY {"}SELECT: {keydisp1}{"} <<else>> @ row+1,0 SAY {"} {keydisp2}{"} @ row,0 SAY {"}SELECT: {keydisp1}{"} <<endif>> DO GetKey WITH dbfchoice,{"}{keyopts1}{keyopts2}{"}+Returnkey IF dbfchoice = Returnkey RETURN ENDIF dbfarea = dbfchoice DO {fileprefix}_AREA RETURN <<end>> <<*GenSetFile*>> <<procedure GenSetArea>> <<begin>> PROCEDURE {fileprefix}_AREA SELECT &dbfarea <<if ismultials>> DO CASE <<endif>> <<forall databases>> <<if ismultials>> CASE dbfarea = {"}{dbfcount}{"} <<pushmargin( 2 )>> <<else>> <<pushmargin( 1 )>> <<endif>> <<# GenFileVars if ndxtotal = 0 genln( '* ---<No indexes>.' ) genln( 'NdxOrder = "0"' ) else GenIndexVars genln( 'NdxOrder = "1"' ) endif if ismultipage select field 1 genln( 'pageno = ',fldpag ) genln( 'dbfpagemax = ',pagtotal ) endif popmargin endfor #>> <<if ismultials>> ENDCASE <<endif>> LastRec = RECCOUNT() RETURN <<end GenSetArea>> <<# procedure GenProcSecond begin GenSetArea if ismultials GenSetFile endif GenFuncStandard select all if ndxtotal > 1 if ismultials forall databases if ndxtotal > 1 GenSetIndex( fileprefix + '_' + chr( 64 + dbfcount ) + 'NDX' ) endif endfor if ismultindx GenSetNdxs endif else select database 1 GenSetIndex( fileprefix + '_NDXS' ) endif endif select all if ndxtotal > 0 <<*Total ndxs for entire system*>> if ismultials forall databases if ndxtotal > 0 <<*Total ndxs for each dbf*>> GenSingleSEEK endif endfor GenMultiSEEK else select database 1 GenSingleSEEK endif endif end>> <<*GenProcSecond*>> <<* EOF: APPPROC.INC *>> #>>