Liren Large Software Subsidy 5

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

/ Liren Large Software Subsidy 5 / 05.iso / a / a046 / 5.img / TEMPLATE / SSBPROC.INC < prev next >

Wrap

Text File | 1992-04-01 | 9.9 KB | 495 lines

<<* SSBPROC.INC *>> <<* (C) 1991 SHEN YANG WHITE HORSE SOFTWART COMPANY *>> <<procedure GenProcStandard>> <<string alpha>> <<begin>> PROCEDURE SayRec * ---"SayRec" is used by the EDIT program and PROCEDURE DoCONT. * DO StatLine WITH RECNO(),DELETED() DO {fileprefix}S RETURN PROCEDURE GetKey PARAMETER choice,keychars PRIVATE keycode choice = "*" DO WHILE .NOT. (choice $ keychars) keycode = INKEY() IF keycode > 0 choice = UPPER(CHR(keycode)) ENDIF 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,0 SAY STR( recnum,7,0 ) + "/"+LTRIM( STR(Reccount()) ) <<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 " <Del> " ELSE @ 0,50 SAY " " ENDIF RETURN PROCEDURE PromptBar <<GenColor( 0,'HILITE' )>> * STORE DATE4(DATE()) TO SYSDATE @ 22,0 SAY SPACE(80) &&CLEAR LINE @ 22,70 SAY DATE() &&SYSDATE * ---Center the menu heading. col = (80 - LEN(menuhdg)) / 2 @ 22,col SAY menuhdg <<Gencolor( 0,'SCREEN' )>> Return PROCEDURE SayEOF PARAMETER row,oldrecnum <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR IF EOF() @ row,0 SAY "╧╓╘┌╩╟╩²╛▌┐Γ╓╨╡─╫ε║≤╥╗╕÷╝╟┬╝" ELSE @ row,0 SAY "╧╓╘┌╩╟╩²╛▌┐Γ╓╨╡─╡┌╥╗╠⌡╝╟┬╝" 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 @ 23,17 SAY "{ 1 ⌐ñ " @ 23,24 SAY SUBSTR( STR( lastrecnum + 1000000,7 ),2 ) + " } + {Return}" ?? SYS(2002,1) @ 24,17 SAY "╟δ ╩Σ ╚δ ╝╟ ┬╝ ║┼ :" GET recnum; PICTURE "@Z 9999999" RANGE 0,lastrecnum READ ?? SYS(2002) IF recnum > 0 GOTO recnum ENDIF RETURN PROCEDURE DoGOTO PARAMETER row,recnum,lastrecnum PRIVATE menuchoice recnum = 0 <<GenColor( 1,'PROMPT' )>> @ 23,0 CLEAR menuchoice = 4 @ 23, 5 PROMPT '1.╡┌╥╗╠⌡╝╟┬╝' @ 23,20 PROMPT '2.╫ε║≤╥╗╠⌡╝╟┬╝' @ 23,37 PROMPT '3.╓╕╢¿╝╟┬╝║┼' @ 23,52 PROMPT '4.╖╡ ╗╪' MENU TO menuchoice choice = SUBSTR( Returnkey+"TBR"+Returnkey,menuchoice + 1,1 ) @ 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,"╒²╘┌╝∞╦≈╢¿╬╗..." LOCATE FOR &expr IF EOF() DO SayEOF WITH row,oldrecnum ELSE @ row,0 CLEAR @ row,0 SAY "╢¿╬╗╘┌" 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,"╝╠╨°┬≡? (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 PROCEDURE DoBROW PRIVATE FLDNUM STORE 0 TO FLDNUM GO TOP <<GenColor( 0,'PROMPT')>> @ 22, 0 CLEAR TO 22,79 @ 22, 5 SAY "╟δ ╚╖ ╢¿ ▓╗ ╥╞ ╢» ╡─ ╫╓ ╢╬ ╩² :" GET FLDNUM PICT '@Z 9' READ <<GenColor( 0,'SCREEN')>> BROW LOCK FLDNUM <<GenColor( 0,'PROMPT')>> 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 := fixareafldnam #>> <<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 := fixareafldnam if forcount = 1 firstpart := '@ row, 0 SAY "Enter ' + fldlab + '"' else firstpart := '@ row+1,0 SAY " ' + fldlab + '"' 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,"╣╪╝ⁿ╫╓▒φ┤∩╩╜╙δ╩²╛▌┐Γ╣╪╝ⁿ╫╓▓╗╞Ñ┼Σ." WAIT @ row,0 CLEAR <<else>> READ <<GenExecSeek>> <<endif>> <<select all fields>> <<end GenKeySeek>> <<procedure GenSingleSEEK>> <<string alpha,fixedkey>> <<begin>> <<alpha := chr( dbfcount + 64 )>> <<if not ismultials>> PROCEDURE {fileprefix}Z PARAMETER row PRIVATE expr IF NdxOrder = "0" RETURN ENDIF <<endif>> <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR DO CASE <<forall indexes>> CASE NdxOrder = {"}{ndxcount}{"} <<GenKeySeek>> <<endfor>> ENDCASE <<if not ismultials>> RETURN <<endif>> <<end GenSingleSEEK>> <<procedure GenMultiSEEK>> <<string alpha>> <<begin>> PROCEDURE {fileprefix}Z PARAMETER row IF NdxOrder = "0" RETURN ENDIF DO CASE <<forall databases>> CASE dbfarea = {"}{dbfcount}{"} <<if ndxtotal > 0>> <<pushmargin(1)>> <<GenSingleSEEK>> <<popmargin>> <<else>> * ---<none>. <<endif>> <<endfor>> ENDCASE RETURN <<end>> <<*GenMultiSEEK*>> <<procedure GenSetIndex( procname : string )>> <<string keydisp,keyopts,ndxnames>> <<integer width,col,i>> <<begin>> <<if not(ismultials)>> PROCEDURE {procname} PARAMETER row,ndxchoice <<endif>> <<GenColor( 1,'PROMPT' )>> @ row,0 CLEAR <<# forall indexes filespec( ndxnam,fpath,fname,fext ) keydisp := keydisp + ' ' + str( ndxcount ) + '-' + fname + ' ' genln(' MSG',str( ndxcount ),' = "',fname,'"' ) keyopts := keyopts + str( ndxcount ) endfor #>> @ 24,0 CLEAR @ 24,0 SAY 'Select index...' @ 23,0 CLEAR <<col := 2>> <<for i := 1 to ndxtotal>> @ 23,{col} PROMPT {"}indexfile{i}{"} MESSAGE SPACE(20) + MSG{i} + {"}.{fext}{"} <<col := col + 11>> <<end>> MENU TO menuchoice IF menuchoice = 0 RETURN ENDIF STORE STR(menuchoice,1,0) to ndxchoice, NdxOrder SET ORDER TO &NdxOrder <<if not(ismultials)>> RETURN <<endif>> <<end>> <<*GenSetIndex*>> <<procedure GenSetNdxs>> <<string alpha,keydisp,keyopts,ndxnames>> <<begin>> PROCEDURE {fileprefix}X PARAMETER row,ndxchoice DO CASE <<forall databases>> CASE dbfarea = {"}{dbfcount}{"} <<if ndxtotal > 1>> <<pushmargin(1)>> <<GenSetIndex('')>> <<popmargin>> <<else>> * ---Only one index. <<endif>> <<endfor>> ENDCASE RETURN <<end>> <<*GenSetNdxs*>> <<procedure GenSetArea>> <<begin>> PROCEDURE {fileprefix}A PRIVATE oldrecnum SELECT &dbfarea oldrecnum = RECNO() <<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() IF oldrecnum > 0 .AND. LastRec > 0 GOTO oldrecnum ENDIF RETURN <<end GenSetArea>> <<# procedure GenProcSecond begin GenSetArea GenFuncStandard select all if ndxtotal > 1 if ismultials if ismultindx GenSetNdxs endif else select database 1 GenSetIndex( fileprefix + 'X' ) endif endif select all if ndxtotal > 0 <<*Total ndxs for entire system*>> if ismultials GenMultiSEEK else select database 1 GenSingleSEEK endif endif end>> <<*GenProcSecond*>> <<* EOF: SSBPROC.INC *>> #>>