home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / EXTNDB22.ZIP / EXTENDB2.PRG
Encoding:
Text File  |  1987-04-01  |  33.2 KB  |  1,418 lines
  1. * Filename: EXTENDB2.PRG
  2. * Program.: Additions to the Clipper Extended Library by Tom Rettig
  3. * Author..: John Kaster
  4. * Date....: September 2, 1986
  5. * Notice..: Placed in the public domain by John Kaster.
  6. *           Clipper is a trademark of Nantucket.
  7. *           FlashUp Windows is a trademark of The Software Bottling Company
  8. *           of New York.  It is an excellent Window, Screen and Help window
  9. *           utility that can be used with many languages.  Call them for
  10. *           more information - they're not paying me for advertising.
  11. * Notes...: Since I wrote these functions and procedures for my own use, any
  12. *           confusing abbreviations or code without comments is because I hate
  13. *           documenting things already completed.  If any coding is unclear,
  14. *           you may direct questions to me on EXEC-PC BBS in Milwaukee at
  15. *           414/964-5160 (9600 baud capable, N, 8, 1; Kermit, Ymodem and Xmodem
  16. *           support), or ACUMEN at 703-321-7441 (2400 baud).
  17. *           If anyone has working FKLABEL(),NDX() functions, I would
  18. *           appreciate a copy.
  19. *
  20. *           Following is a list of user defined functions to extend Clipper's
  21. *           abilities:
  22. *
  23. *           New Functions Not found in Clipper
  24. *           DELCOUNT()    ::= # of records marked for deletion in current file
  25. *           DIV()         ::= integer division of n1 by n2
  26. *           EDFUNC()      ::= My editor function for the DBEDIT function in DBU
  27. *                             library
  28. *           FEXISTS()     ::= T/F if file with/without extension exists
  29. *           FIELDNUM()    ::= # of 'field' in currently used file
  30. *           JUSTIFY()     ::= space(difference b/n Field Length & Field Name)
  31. *           KNT()         ::= # of times a string occurs in Mem/Char field + 1
  32. *           LOGIC()       ::= Any part of 'Yes' or 'No ' value of logic variable
  33. *           PERC()        ::= 100 * Num1/Num2
  34. *           RITE()        ::= string of any variable, with two options
  35. *           SPERC()       ::= string of PERC()
  36. *           STRIP()       ::= Memo/Character field with <Target> stripped out
  37. *                             or optionally replaced with <Replacement>
  38. *           SZERO()       ::= string(Zero())
  39. *           ULEN()        ::= length of any type of variable
  40. *           ZERO()        ::= n1/n2 if n2#0, otherwise 0
  41. *
  42. *
  43. *           PROCEDURES
  44. *           CNTR       ::= Center text on a line
  45. *           CORRECT    ::= If get variables were updated, asks if correct
  46. *           FORMFEED   ::= Form feed for whatever output you have
  47. *           GENSEEK    ::= Generic seeking procedure (any index!)
  48. *           INDEX      ::= Revised Nantucket index.PRG
  49. *           OOPS       ::= Flashing message centered on line 0
  50. *           OPCHOICE   ::= Select an output device and set it
  51. *           OPTIONS    ::= Options for EDFUNC()
  52. *           PACKEM     ::= generic pack utility
  53. *           PRINTOFF   ::= Output redirection procedure
  54. *           PRINTON    ::= Output redirection procedure
  55. *           RESETINDEX ::= Generic index (re)setter
  56. *           SELEFIELDS ::= Select fields from the current database
  57. *           SELEFILE   ::= Select a file from the current subdirectory
  58. *           SETFILT    ::= Set a filter
  59. *           SHOWFIELDS ::= Show the fields in the currently selected database
  60. *           SHOWFILES  ::= Display the files on current subdirectory
  61. *           STATUS     ::= Closest I could get to dB3's display status
  62. *           TITLE      ::= Make a title on the screen
  63. *
  64. *
  65.  
  66. FUNCTION DIV
  67. * Syntax:  DIV( <ExpN1>, <ExpN2> )
  68. * Notes.:  Returns int(<ExpN1>/<ExpN2>) if <ExpN2>#0, otherwise 0
  69. PARA ZN1,ZN2
  70. IF PCOUNT()<2
  71.   RETURN (0)
  72. ENDIF
  73. IF ZN2=0
  74.   RETURN (0)
  75. ENDIF
  76. RETURN ( INT(ZN1/ZN2))
  77.  
  78. FUNCTION DELCOUNT
  79. * Syntax.: Delcount ( [<ExpC>] )
  80. * Returns: Number of records marked for deletion in the <ExpC> or current file
  81. *
  82. PARA D_File
  83. PRIV K,RetArea
  84. RetArea=ALIAS()
  85. IF PCOUNT()>0
  86.   IF TYPE('D_File')='C'
  87.     SELE &D_File
  88.   ENDIF
  89. ENDIF
  90. SET DELE OFF
  91. COUN FOR DELETED() TO K
  92. SET DELE ON
  93. SELE &RetArea
  94. RETURN (K)
  95.  
  96. FUNCTION FIELDNUM
  97. * Syntax: FIELDNUM( <ExpC> )
  98. * Return: The field number of <ExpC> in current DBF, or '0' if not found
  99. *
  100. PARAMETERS fldname
  101. PRIVATE Kount,fit
  102. KOUNT=1
  103. fit=0
  104. DO WHILE field(KOUNT)>' '.AND.fit=0
  105.   IF trim(field(KOUNT))=trim(fldname)
  106.     fit=Kount
  107.   ENDIF
  108.   KOUNT=KOUNT+1
  109. ENDDO
  110. RETURN (fit)
  111.  
  112. FUNCTION JUSTIFY
  113. * Syntax: JUSTIFY ( <Exp?> )
  114. * Return: Number of spaces = the difference in Length b/n name of variable and
  115. *         its contents
  116. PARAMETERS Width
  117. PRIVATE Difference
  118. IF TYPE('Width')='U'
  119.   RETURN ('')
  120. ELSE
  121.   Difference=len(Width)-ulen(Width)
  122.   RETURN (space(abs(Difference)))
  123. ENDIF
  124.  
  125. FUNCTION Logic
  126. * Syntax.: LOGIC( <ExpL>, [<length>] )
  127. * Return.: The leftmost <ExpN> of 'Yes' or 'No ', or 'Yes' or 'No ' + <length>
  128. *          minus 3 spaces
  129. * Default: <length> = 3
  130. *
  131. PARA YN,Lnth
  132. PRIV st
  133. IF Type('Lnth')='U'
  134.   Lnth=3
  135. ENDIF
  136. IF YN
  137.   st='Yes'
  138. ELSE
  139.   st='No '
  140. ENDIF
  141. IF Lnth>3
  142.   RETURN (st+space(Lnth-3))
  143. ELSE
  144.   RETURN (LEFT(st,Lnth))
  145. ENDIF
  146.  
  147. FUNCTION PERC
  148. * Syntax.: PERC( <ExpN1> , <ExpN2> )
  149. * Return.: 100 * <ExpN1> / <ExpN2>
  150. *
  151. PARA Made,Att
  152. IF Type('Made')<>'N'.OR.Type('Att')<>'N'
  153.   RETURN(0)
  154. ELSE
  155.   RETURN(100*ZERO(Made,Att))
  156. ENDIF
  157.  
  158. FUNCTION SPERC
  159. * Syntax.: SPERC( <ExpN1> , <ExpN2> , [<width>,[<decimal>]] )
  160. * Return.: str(100 * <ExpN1>/<ExpN2>,<width>,<decimal>)
  161. * Default: <width> = 7, <decimal> = 3
  162. *
  163. PARA Made,Att,Wid,Dec
  164. IF type('Dec') # 'N'
  165.   Dec=3
  166. ENDIF
  167. IF Type('Wid') # 'N'
  168.   Wid=7
  169. ENDIF
  170. IF Type('Made')<>'N'.OR.Type('Att')<>'N'
  171.   RETURN(repl('*',wid))
  172. ELSE
  173.   RETURN(str(PERC(Made,Att),Wid,Dec))
  174. ENDIF
  175.  
  176. FUNCTION Rite
  177. * Syntax.: RITE( <Exp?>, [<Delimiter>] )
  178. * Return.: A character string of <Exp?> either len(<Exp?>) long or the
  179. *          "ALLTRIM( <Exp?> )"
  180. * Default: <Delimiter> = ''
  181. *
  182. PARA FldName,Delim
  183. PRIV St
  184. IF Type('Delim') # 'C'
  185.   Delim=''
  186. ENDIF
  187. DO CASE
  188. CASE Delim='D'
  189.   DO CASE
  190.   CASE TYPE('&FldName')='D'
  191.     st=DTOC(&FldName)
  192.   CASE TYPE('&FldName')='N'
  193.     st=ltrim(str(&FldName))
  194.   CASE TYPE('&FldName')='L'
  195.     st=trim(logic(&FldName))
  196.   CASE TYPE('&FldName')='M'
  197.     st=trim(strip(FldName))
  198.   OTHERWISE
  199.     st=Alltrim(&FldName)
  200.   ENDCASE
  201.   st='"'+st+'"'
  202. OTHERWISE
  203.   DO CASE
  204.   CASE TYPE('&FldName')='D'
  205.     st=DTOC(&FldName)
  206.   CASE TYPE('&FldName')='N'
  207.     st=str(&FldName)
  208.   CASE TYPE('&FldName')='L'
  209.     st=logic(&FldName)
  210.   CASE TYPE('&FldName')='M'
  211.     st=strip(FldName)
  212.   OTHERWISE
  213.     st=&FldName
  214.   ENDCASE
  215. ENDCASE
  216. RETURN (st)
  217.  
  218. FUNCTION Strip
  219. * Syntax.: STRIP( <ExpC> [<Target>, [<Replacement>]])
  220. * Notes..: <ExpC> is name of Memo/Character field to strip <Target> from,
  221. *          or replace target with <Replacement>
  222. * Return.: Memo field without <Target> or replaced with <Replacement>
  223. * Default: <Target to Strip> = Soft Carriage Return for memo field
  224. *
  225. PARA Memo,Tar,Repl
  226. PRIV st,bltst
  227. IF TYPE('TAR') ='U'
  228.   tar=chr(141)+chr(10)
  229. ENDIF
  230. IF TYPE('TAR') # 'C' .OR. EMPTY(Tar)
  231.   Tar=chr(141)+chr(10) && Soft return code for memos
  232. ENDIF
  233. IF TYPE('REPL') # 'C'
  234.   Repl=''
  235. ENDIF
  236. BltSt=''
  237. IF ! TYPE(Memo) $ 'MC'
  238.   RETURN ('')
  239. ELSE
  240.   st=&memo
  241.   DO WHILE AT(Tar,st)>0
  242.     BltSt=BltSt+LEFT(st,at(Tar,st)-1)+Repl
  243.     st=RIGHT(st,len(st)-at(Tar,st)-len(tar)+1)
  244.   ENDDO
  245.   IF ! EMPTY(St)
  246.     BltSt=BltSt+St
  247.   ENDIF
  248.   RETURN (BltSt)
  249. ENDIF
  250.  
  251. FUNCTION Knt
  252. * Syntax.: KNT( <ExpM>, [<separator>] )
  253. * Return.: Number of words, or # of occurences of [<separator>] in <ExpM>
  254. * Default: <Separator> = space(1)
  255. *
  256. PARA Targ,Sep
  257. IF Type('Sep') # 'C'
  258.   Sep=' '
  259. ENDIF
  260. PRIV Kount,St
  261. Kount=0
  262. St=Targ
  263. IF Type('Targ')$'CM'
  264.   DO WHILE AT(sep,st)>0
  265.     Kount=Kount+1
  266.     st=Right(st,len(st)-at(sep,st)-len(sep)+1)
  267.     IF AT(sep,st)=1
  268.       DO WHILE AT(Sep,st)=1
  269.         st=Right(st,len(st)-at(sep,st)-len(sep)+1)
  270.       ENDDO
  271.     ENDIF
  272.   ENDDO
  273.   IF sep=' '
  274.     Kount=Kount+1
  275.   ENDIF
  276. ENDIF
  277. RETURN (Kount)
  278.  
  279. PROCEDURE SHOWFIELDS
  280. * Syntax: DO SHOWFIELDS
  281. * Notes.: Displays the fields in the currently selected database
  282. *
  283. PRIV I,FSTOP
  284. FSTOP=FCOUNT()
  285. BotLine=6+DIV(FSTOP,6)
  286. DO BOXIT WITH 4,0,BotLine,79,1
  287. FOR I=1 TO FSTOP
  288.  DO COL1
  289.  @ 5+DIV(I-1,6),5+MOD(i-1,6)*12 SAY type(Field(I))
  290.  DO COL2
  291.  ?? FIELD(I)
  292. NEXT
  293. DO COL1
  294. RETURN
  295.  
  296. PROCEDURE SELEFIELDS
  297. * Syntax: DO SELEFIELDS
  298. * Notes.: Calls SHOWFIELDS, then allows you to select any and all fields in
  299. *         the file and returns the field list in the array FLIST
  300. *         Possible problems - does not detect for doubled variable selection,
  301. *         because I didn't want to - maybe someone wants to use a field twice
  302. *
  303. PARA FLIST,FNUM
  304. IF EMPTY(Alias())
  305.   DO OOPS WITH 'No file has been selected'
  306.   RETU
  307. ENDIF
  308. IF PCOUNT()<1
  309.   DO OOPS WITH 'An array must be passed to SELEFIELDS'
  310.   RETU
  311. ENDIF
  312. IF PCOUNT()<2
  313.   FNUM=FCOUNT()
  314. ENDIF
  315. IF TYPE('FLIST')#'A'
  316.   DO OOPS WITH 'An array must be passed to SELEFIELDS'
  317.   RETU
  318. ENDIF
  319. PRIV Row,Col,LastLine,I,J
  320. DO COL1
  321. CLEA
  322. DO TITLE WITH 'Selecting fields from '+ALIAS()
  323. DO SHOWFIELDS
  324. i=1
  325. FStop=Fcount()
  326. IF DIV(FStop,6)=1
  327.   LastLine=1
  328. ELSE
  329.   LastLine=DIV(FStop,6)+1
  330. ENDIF
  331. @ 23,0 SAY 'Fields'
  332. SET COLO TO W+
  333. key=0
  334. FNUM=0
  335. DO WHIL key#27
  336.   SET COLO TO W+
  337.   @ 5+DIV(I-1,6),4+MOD(I-1,6)*12 SAY ''
  338.   key=inkey(0)
  339.   @ 5+DIV(I-1,6),4+MOD(I-1,6)*12 SAY ' '
  340.   DO COL1
  341.   DO CASE
  342.   Case Key=HelpKey
  343.     @ 0,0 SAY 'Move: arrows, [Home], [End]; [Enter] selects field, [D]elete field, [Esc] leaves'
  344.   CASE Key=LfArrow
  345.     i=IF(I>1,i-1,i)
  346.   CASE Key=RtArrow
  347.     i=IF(i<FStop,i+1,i)
  348.   CASE Key=HomeKey
  349.     i=1
  350.   CASE Key=EndKey
  351.     I=FCount()
  352.   CASE Key=UpArrow
  353.     i=IF(i-6>1,i-6,1)
  354.   CASE Key=DnArrow
  355.     i=if(I+6<Fcount(),i+6,Fcount())
  356.   CASE (Key=68.OR.Key=100).AND.FNUM>0 && D or d
  357.     FLIST[FNUM]=.F.
  358.     FNUM=FNUM-1
  359.     @ 23,7
  360.     @ 24,0
  361.     IF FNUM>0
  362.       DO COL2
  363.       @ 23,7 SAY FLIST[1]
  364.       FOR J = 2 to FNUM
  365.         ?? ','+trim(FLIST[J])
  366.       NEXT
  367.       DO COL1
  368.     ENDIF
  369.   CASE Key=13
  370.     IF FNUM<FCOUNT()
  371.       FNUM=FNUM+1
  372.       FLIST[FNUM]=FIELD(I)
  373.       i=IF(i<Fstop,i+1,1)
  374.       @ 23,7
  375.       DO COL2
  376.       @ 23,7 SAY FLIST[1]
  377.       FOR J = 2 to FNUM
  378.         ?? ','+trim(FLIST[J])
  379.       NEXT
  380.       DO COL1
  381.     ELSE
  382.       DO OOPS WITH 'Attempted to select more fields than there are.'
  383.     ENDIF
  384.   ENDC
  385. ENDDO
  386. RETU
  387.  
  388. FUNC FExists
  389. * Syntax: FExists ( <ExpC>, [<Ext>] )
  390. * Return: .T. if <ExpC> empty or it exists, .F. if not
  391. *
  392. PARA File,Ext
  393. IF PCOUNT()<1
  394.   RETURN ( .T. )
  395. ENDIF
  396. IF PCOUNT()<2
  397.   Ext='.'
  398. ELSE
  399.   IF TYPE('Ext')='C'
  400.     Ext='.'+alltrim(Ext)
  401.   ELSE
  402.     Ext='.'
  403.   ENDIF
  404. ENDIF
  405. IF ! EMPTY(File)
  406.   RETURN ( File (IF(AT('.',File)=0,trim(File)+Ext,file)) )
  407. ENDIF
  408. RETURN ( .T. )
  409.  
  410. PROCEDURE SHOWFILES
  411. * Syntax:  DO SHOWFILES WITH [<Mask>],[<Array of Files>],[<# of Files>],[<Title>]
  412. * Notes.:  Returns the list of files in <Array of Files>
  413. *
  414. PARA Mask,Files,Num,Title
  415. IF PCOUNT()<1
  416.   Mask='*.*'
  417. ENDIF
  418. IF TYPE('Mask')#'C'
  419.   Mask='*.*'
  420. ENDIF
  421. IF PCOUNT()<2
  422.   DECLARE FILES[ADIR(Mask)]
  423. ENDIF
  424. IF TYPE('FILES')#'A'
  425.   DECLARE FILES[ADIR(MASK)]
  426. ENDIF
  427. IF PCOUNT()<3
  428.   Num=ADIR(Mask,Files)
  429. ENDIF
  430. IF TYPE('Num')#'C'
  431.   Num=ADIR(Mask,Files)
  432. ENDIF
  433. IF TYPE('Title')#'C'
  434.   Title='Directory of '+trim(Mask)+' Files'
  435. ENDIF
  436. DO COL1
  437. CLEA
  438. DO TITLE WITH Title
  439. DO BOXIT WITH 3,0,5+DIV(Num-1,5),79
  440. FOR I = 1 to num
  441.   @ 4+DIV(I-1,5),5+MOD(i-1,5)*14 SAY Files[I]
  442. NEXT
  443. RETU
  444.  
  445. PROCEDURE SELEFILE
  446. * Syntax:  DO SHOWFILES WITH [<Mask>],[<FName>],[<Must exist?>],[<Title>]
  447. * Notes.:  Returns the name of the file selected.  Calls SHOWFILES
  448. *
  449. PARA Mask,Selected,MustExist,Title
  450. PRIV Row,Col,LastLine,ValCon,Ext,Num,I,Prefix
  451. IF PCOUNT()<1
  452.   Mask='*.*'
  453. ENDIF
  454. IF TYPE('Mask')#'C'
  455.   Mask='*.*'
  456. ENDIF
  457. Selected=Mask
  458. IF PCOUNT()<3
  459.   MustExist=.F.
  460. ENDIF
  461. IF TYPE('MustExist')#'L'
  462.   MustExist=.F.
  463. ENDIF
  464. IF MustExist
  465.   ValCon='Selected'
  466. ELSE
  467.   ValCon="''"
  468. ENDIF
  469. IF PCOUNT()<4
  470.   Title='Directory of '+alltrim(Mask)+' files.'
  471. ENDIF
  472. DO WHIL '*' $ Selected
  473.   Ext=''
  474.   Mask=Selected
  475.   IF ! '.*' $ Mask
  476.     Ext=RIGHT(Mask,len(Mask)-AT('.',Mask))
  477.   ENDIF
  478.   DECLARE FILES[ADIR(Mask)]
  479.   Num=0
  480.   DO SHOWFILES WITH Mask,Files,Num,Title
  481.   Insert=''
  482.   DO CASE
  483.   CASE '\' $ Mask
  484.     p=len(mask)-2
  485.     DO WHIL substr(mask,p,1)#'\'.AND.P>0
  486.       p=p-1
  487.     ENDDO
  488.     IF P>0
  489.       Insert=left(mask,p)
  490.     ENDIF
  491.   CASE ':' $ Mask
  492.     p=len(mask)-2
  493.     DO WHIL ( ! substr(mask,p,1) $ ':\').AND.P>0
  494.       p=p-1
  495.     ENDDO
  496.     IF P>0
  497.       Insert=left(mask,p)
  498.     ENDIF
  499.   ENDC
  500.   I=1
  501.   IF ! Empty(Selected)
  502.     I=ASCAN(Files,Selected)
  503.   ENDIF
  504.   I=IF(I<1,1,I)
  505.   IF DIV(Num,5)=1
  506.     LastLine=1
  507.   ELSE
  508.     LastLine=DIV(Num,5)+1
  509.   ENDIF
  510.   @ 24,0 SAY 'File '
  511.   SET COLO TO W+
  512.   Selected=Files[I]
  513.   key=0
  514.   DO WHIL key#13.AND.key#27.AND.Num>0
  515.     DO COL2
  516.     @ 24,5
  517.     @ 24,5 SAY Insert+trim(Files[I])+space(60-len(Insert+trim(files[i])))
  518.     SET COLO TO W+
  519.     @ 4+DIV(I-1,5),4+MOD(I-1,5)*14 SAY ''
  520.     key=inkey(0)
  521.     @ 4+DIV(I-1,5),4+MOD(I-1,5)*14 SAY ' '
  522.     DO CASE
  523.     Case Key=HelpKey
  524.       DO COL1
  525.       @ 0,0 SAY 'Move: arrows, [Home], [End]; [Enter] selects file, [Esc] to type in file'
  526.     CASE Key=LfArrow
  527.       i=IF(I>1,i-1,i)
  528.     CASE Key=RtArrow
  529.       i=IF(i<num,i+1,i)
  530.     CASE Key=HomeKey
  531.       i=1
  532.     CASE Key=EndKey
  533.       I=Num
  534.     CASE Key=UpArrow
  535.       i=IF(i-5>1,i-5,1)
  536.     CASE Key=DnArrow
  537.       i=if(I+5<Num,i+5,Num)
  538.     CASE Key=13
  539.       Selected=Files[I]
  540.     ENDC
  541.   ENDDO
  542.   IF num>0
  543.     Selected=Insert+trim(Files[I])+space(60-len(Insert+trim(files[i])))
  544.   ELSE
  545.     Selected=space(60)
  546.   ENDIF
  547.   DO COL1
  548.   @ 0,0
  549.   IF Key#13
  550.     @ 24,5
  551.     @ 24,5 GET Selected PICT '@K!' VALI FExists(&ValCon,Ext)
  552.     READ
  553.   ENDIF
  554. ENDDO
  555. RETU
  556.  
  557. PROCEDURE INDEX
  558. * Syntax:  DO INDEX
  559. * Notes.:  Revised code from Nantucket
  560. *
  561. IF EMPTY(ALIAS())
  562.   DBFile=space(20)
  563.   DO SELEFILE WITH '*.DBF',DBFile,.T.,'Select a data file to index'
  564.   IF EMPTY(DBFILE)
  565.     RETU
  566.   ENDIF
  567.   USE &DBFile
  568. ENDIF
  569. NDXFile=space(20)
  570. DO SELEFILE WITH '*.DBF',NDXFile,.F.,'Select an index file name'
  571. IF EMPTY(NDXFile)
  572.   RETU
  573. ENDIF
  574. IF FILE(NDXFile)
  575.   USE &DBFile INDE &NDXFile
  576.   Key=INDEXKEY(0)
  577. ENDIF
  578. CLEA
  579. DO TITLE WITH 'Creating an index file'
  580. @ 12,0 SAY 'Key expression: ' GET Key
  581. READ
  582. INDEX ON &key TO &ntx
  583. ? RECCOUNT(), " Records indexed"
  584. RETU
  585.  
  586. PROCEDURE TITLE
  587. * Syntax.: DO TITLE WITH <Title>, [<starting line>]
  588. * Notes..: Clears line 1 and 2 and centers <Title> on line 1
  589. *
  590. PARAMETER Ttl,start
  591. IF TYPE('Start')<>'N'
  592.   Start=1
  593. ENDIF
  594. @ Start,0
  595. @ Start+1,0
  596. BFrame = '┌ ┐│╛═╘│'
  597. Cent=INT(len(Ttl)/2)
  598. BotLine=INT(FCOUNT()/6+5)
  599. IF ISCOLOR()
  600.   SET COLOR TO RB/N
  601. ELSE
  602.   SET COLOR TO W/N
  603. ENDIF
  604. @ Start,40-cent-2,Start+1,40+cent+IF(LEN(Ttl)/2=INT(len(Ttl)/2),1,2) BOX Bframe
  605. SET COLO TO W+/N
  606. @ Start,40-cent-1 SAY ' '+Ttl+' '
  607. DO COL1
  608. RETURN
  609.  
  610. PROCEDURE OOPS
  611. * Syntax.: DO OOPS WITH <Message>
  612. * Notes..: Centers <Message> on line 24, and flashes it until a key is pressed
  613. *
  614. PARAMETER Mess
  615. IF ISCOLOR()
  616.   SET COLOR TO R+*/N
  617. ELSE
  618.   SET COLOR TO W+*/N
  619. ENDIF
  620. @ 0,40-len(Mess)/2 SAY Mess
  621. key=inkey(0)
  622. DO COL1
  623. @ 0,40-len(mess)/2 say space(Len(Mess))
  624. RETURN
  625.  
  626. PROCEDURE PRINTOFF
  627. * Syntax.: DO PRINTOFF
  628. * Notes..: Assumes a public variable OUTPUT of type Character
  629. * Default: OUTPUT = 'S'creen
  630. *
  631. IF TYPE('OUTPUT') # 'C'
  632.   OUTPUT='S'
  633. ENDIF
  634. IF OUTPUT='S'
  635.   WAIT
  636.   CLEA
  637. ENDIF
  638. SET ALTERNATE OFF
  639. SET PRINT OFF
  640. IF OUTPUT='D'
  641.   CLOSE ALTERNATE
  642. ENDIF
  643. OUTPUT='S'
  644. SET CONSOLE ON
  645. RETURN
  646.  
  647. PROCEDURE PRINTON
  648. * Syntax.: DO PRINTON
  649. * Notes..: Assumes a public variable OUTPUT as type 'C' for "S"creen, "P"rinter,
  650. *          or "D"isk
  651. * Default: OUTPUT = 'S'creen
  652. *
  653. IF TYPE('OUTPUT') = 'U'
  654.   PUBLIC OUTPUT
  655.   OUTPUT='S'
  656. ENDIF
  657. IF TYPE('OUTPUT') # 'C'
  658.   OUTPUT='S'
  659. ENDIF
  660. SET PRINT OFF
  661. SET CONSOLE OFF
  662. SET ALTERNATE OFF
  663. DO CASE
  664. CASE UPPER(OUTPUT)='D'
  665.   SET ALTERNATE ON
  666. CASE UPPER(OUTPUT)='P'
  667.   IF ISPRINT()
  668.     SET PRINT ON
  669.   ELSE
  670.     ?? chr(7)
  671.     @ 0,0 SAY 'Hit any key when the printer is ready. [Esc] for Screen output.'
  672.     key=inkey(0)
  673.     DO WHILE Key#27 .AND. (! ISPRINT())
  674.       KEY=INKEY(0)
  675.     ENDDO
  676.     IF Key=27
  677.       SET CONS ON
  678.       OUTPUT='S'
  679.       Pause=.T.
  680.       @ 24,0 SAY 'Pause for each page (Y/N)? ' GET Pause
  681.       READ
  682.       @ 24,0
  683.     ENDIF
  684.     @ 0,0
  685.   ENDIF
  686. OTHE
  687.   SET CONSOLE ON
  688. ENDCASE
  689. RETURN
  690.  
  691. FUNCTION edfunc
  692. * Syntax:  Controlled by DBEDIT() in DBU.LIB
  693. * Notes.:  Powerful browsing function utility (more than dBASE has!)
  694. *
  695. PARAMETERS mode,i
  696. PRIVATE cur_field,Key
  697. Key=LastKey()
  698.  
  699. * get the name of the current field into a regular variable
  700. cur_field = field_list[i]
  701.  
  702. ?? 'before case'
  703. inkey(0)
  704. DO CASE
  705.  
  706. CASE mode = 0
  707.   * idle mode..display record number
  708.   @ 0,0 SAY "Record " + STR(RECNO(),7)
  709.   RETURN(1)
  710.  
  711. CASE mode = 1
  712.   DO OOPS WITH "Top of file."
  713.   inkey(1)
  714.   RETURN(1)
  715.  
  716. CASE mode = 2
  717.   Cor=.N.
  718.   Key=Row()+1
  719.   @ Key,0 SAY 'Add another record (Y\N)? ' GET Cor
  720.   READ
  721.   @ Key,0
  722.   IF Cor
  723.     APPE BLAN
  724.   ENDIF
  725.   RETURN(1)
  726.  
  727. CASE mode < 4
  728.   * case action can be implemented for each mode
  729.   RETURN(1)
  730.  
  731. * mode 4..a keystroke not handled by DBEDIT
  732. CASE Key = 27 && Esc
  733.   * escape key..quit
  734.   RETURN(0)
  735.  
  736. CASE Key = 21  &&CtrlU
  737.   IF DELETED()
  738.     RECA
  739.   ELSE
  740.     DELE
  741.   ENDIF
  742.   RETURN (2)
  743.  
  744. CASE Key = 28 && Help Key
  745.   SAVE SCREEN TO EDFUNC1
  746.   DO BOXCOL
  747.   @  0,0 SAY '╔══════════════════╦═════════════════════╦══════════════╦════════════════════╗'
  748.   @  1,0 SAY '║ CURSOR   <-- --> ║         UP   DOWN   ║    DELETE    ║ Insert Mode:  Ins  ║'
  749.   @  2,0 SAY '║  Char:       '+chr(26)+'  ║ Record:           ║ Char:   Del  ║ Exit:        Esc   ║'
  750.   @  3,0 SAY '║  Field: Home End ║ Page:  PgUp  PgDn   ║ Field:  ^Y   ║ Abort:      Alt-C  ║'
  751.   @  4,0 SAY '║  Pan:  ^End ^Home║ File: ^PgUp ^PgDn   ║ Record: ^U   ║                    ║'
  752.   @  5,0 SAY '║  Pan:     ^ ^'+chr(26)+'  ║ Help:   F1          ║              ║ Set Options: ^Enter║'
  753.   @  6,0 SAY '╚══════════════════╩═════════════════════╩══════════════╩════════════════════╝'
  754.   DO BOXIT WITH 7,20,9,60,2
  755.   DO CNTR WITH '[Ctrl-──┘] for other options',8
  756.   key=inkey(0)
  757.   RESTORE SCREEN FROM EDFUNC1
  758.   IF key=10
  759.     DO OPTIONS
  760.     RETURN (2)
  761.   ELSE
  762.     RETURN (1)
  763.   ENDIF
  764.  
  765. CASE Key = 10 && Ctrl-Enter
  766.   DO OPTIONS
  767.   RETURN (2)
  768.  
  769. CASE (Key >31 .AND. Key<127) .OR. Key=13 && Valid ASCII Character
  770.   @ ROW(), COL() GET &cur_field
  771.   IF Key#13
  772.     KEYBOARD chr(Key)
  773.   ENDIF
  774.   READ
  775.   KEYBOARD chr(4) &&Right Arrow
  776.   RETURN (2)
  777.  
  778. OTHE
  779.   RETURN (1)
  780.  
  781. ENDCASE
  782. RETURN (1)
  783.  
  784. PROCEDURE OPTIONS
  785. * Syntax: DO OPTIONS
  786. * Notes.: List of options and executions for browsing.  Called from EDFUNC()
  787. *
  788. PRIV I,Key
  789. SAVE SCREEN TO OPT1
  790. DO BOXIT WITH 0,0,6,79,2
  791. DO CNTR WITH '[F1] - Reset index order       [F2] - seek with active index ',1
  792. DO CNTR WITH '[F3] - DELETE FOR condition    [F4] - DELETE WHILE condition ',2
  793. DO CNTR WITH '[F5] - RECALL FOR condition    [F6] - RECALL WHILE condition ',3
  794. DO CNTR WITH '[F7] - REPLACE FOR condition   [F8] - REPLACE WHILE condition',4
  795. DO CNTR WITH '[F9] - LOCATE FOR condition   [F10] - CONTINUE LOCATE        ',5
  796. Key=inkey(0)
  797. IF TYPE('Cond') = 'U'
  798.   DO OOPS WITH 'Variable "COND" should be public'
  799.   Cond=space(140)
  800. ENDIF
  801. IF TYPE('Cond') # 'C'
  802.   Cond=space(140)
  803. ENDIF
  804. @ 0,0 SAY CLS()
  805. DO CASE
  806. CASE Key = 28 &&F1
  807.   DO RESETINDEX
  808. CASE Key = -1 &&F2
  809.   DO GENSEEK
  810. CASE Key = -2 &&F3
  811.   DO SHOWFIELDS
  812.   DO TITLE WITH 'No commas may be used in DELETING FOR condition'
  813.   @ 23,0 SAY 'Filter ' GET Cond
  814.   READ
  815.   IF ! Empty(Cond)
  816.     DELE FOR &Cond
  817.   ENDIF
  818. CASE Key = -3 &&F4
  819.   DO SHOWFIELDS
  820.   DO TITLE WITH 'No commas may be used in DELETING WHILE condition'
  821.   @ 23,0 SAY 'Filter ' GET Cond
  822.   READ
  823.   IF ! Empty(Cond)
  824.     DELE WHIL &Cond
  825.   ENDIF
  826. CASE Key = -4 &&F5
  827.   DO SHOWFIELDS
  828.   DO TITLE WITH 'No commas may be used in RECALLING FOR condition'
  829.   @ 23,0 SAY 'Condition' GET Cond
  830.   READ
  831.   IF ! Empty(Cond)
  832.     RECA FOR &Cond
  833.   ENDIF
  834. CASE Key = -5 &&F6
  835.   DO SHOWFIELDS
  836.   DO TITLE WITH 'No commas may be used in RECALLING WHILE condition'
  837.   @ 23,0 SAY 'Condition' GET Cond
  838.   READ
  839.   IF ! Empty(Cond)
  840.     RECA WHIL &Cond
  841.   ENDIF
  842. CASE Key = -6 && F7
  843.   DO SHOWFIELDS
  844.   DO TITLE WITH 'No commas may be used in REPLACING FOR condition'
  845.   FN=space(11)
  846.   Exp=SPACE(60)
  847.   @ 22, 0 SAY 'REPL ' GET FN PICT '@!' VALI TYPE(FN)#'U' .OR. EMPTY(FN)
  848.   @ 22,20 SAY 'WITH ' GET Exp
  849.   @ 23, 0 SAY 'FOR  ' GET Cond
  850.   READ
  851.   IF ! (EMPTY(FN).OR.EMPTY(Exp).OR.EMPTY(Cond))
  852.     REPL &FN WITH &Exp FOR &Cond
  853.   ENDIF
  854. CASE Key = -7 && F8
  855.   DO SHOWFIELDS
  856.   DO TITLE WITH 'No commas may be used in REPLACING WHILE condition'
  857.   FN=space(11)
  858.   Exp=SPACE(60)
  859.   @ 22, 0 SAY 'REPL  ' GET FN PICT '@!' VALI TYPE(FN)#'U' .OR. EMPTY(FN)
  860.   @ 22,20 SAY 'WITH  ' GET Exp
  861.   @ 23, 0 SAY 'WHILE ' GET Cond
  862.   READ
  863.   IF ! (EMPTY(FN).OR.EMPTY(Exp).OR.EMPTY(Cond))
  864.     DO WHIL &Cond
  865.       Currec=recno()
  866.       SKIP
  867.       nextrec=recno()
  868.       SKIP -1
  869.       REPL &FN WITH &Exp
  870.       GOTO Nextrec
  871.     ENDDO
  872.   ENDIF
  873. CASE Key = -8 &&F9
  874.   DO SHOWFIELDS
  875.   DO TITLE WITH 'No commas may be used in LOCATING FOR condition'
  876.   @ 23,0 SAY 'Condition' GET Cond
  877.   READ
  878.   IF ! Empty(Cond)
  879.     LOCA FOR &Cond
  880.   ENDIF
  881. CASE Key = -9 &&F10
  882.   CONTINUE
  883. ENDC
  884. REST SCREEN FROM OPT1
  885. RETU
  886.  
  887. PROCEDURE RESETINDEX
  888. * Syntax: DO RESETINDEX
  889. * Notes.: Allows you to change the index order on any active index
  890. *
  891. PRIV I
  892. SAVE SCREEN TO RES1
  893. @ 0,0 SAY CLS()
  894. DO TITLE WITH 'Resetting index order'
  895. @ 4,0 SAY 'Current index: '+IndexKey(0)
  896. Key=1
  897. I = 1
  898. DO WHIL ! Empty(IndexKey(Key))
  899.   ? 'Index',str(Key,2),':',IndexKey(Key)
  900.   key=key+1
  901. ENDDO
  902. IF ! Empty(IndexKey(0))
  903.   @ 24,0 SAY 'Select index number: ' GET I PICT '9' RANG 0,Key
  904.   READ
  905.   SET ORDER TO I
  906. ENDIF
  907. REST SCREEN FROM RES1
  908. RETU
  909.  
  910. PROCEDURE GENSEEK
  911. * Syntax:  DO GENSEEK
  912. * Notes.:  Allows you to do a seek on the active index.  Dynamically
  913. *          determines the picture clause to use depending on the index
  914. *          expression
  915. *
  916. PRIV INK,PC
  917. SAVE SCREEN TO GENSEEK1
  918. @ 0,0 SAY CLS()
  919. DO TITLE WITH 'Seeking with active index on data file '+Alias()
  920. IF ! EMPTY(INDEXKEY(0))
  921.   INK=INDEXKEY(0)
  922.   INK=&INK
  923. ENDIF
  924. DO CASE
  925. CASE EMPTY(INDEXKEY(0))
  926.   @ 4,0 SAY 'No index active.'
  927.   Key=0
  928.   @ 24,0 SAY 'Record number to go to ' GET Key PICT '9999999' RANG 0,RecCount()
  929.   READ
  930.   IF ! Empty(Key)
  931.     GOTO Key
  932.   ENDIF
  933. CASE TYPE('INK')='N'
  934.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  935.   INK=str(INK)
  936.   IF AT('.',INK)>0
  937.     PC=REPL('9',AT('.',INK)-1)+'.'+REPL('9',LEN(INK)-AT('.',INK))
  938.   ELSE
  939.     PC=REPL('9',LEN(INK))
  940.   ENDIF
  941.   INK = 0
  942.   @ 24,0 SAY 'Seek ' GET INK PICT '&PC'
  943.   READ
  944.   SEEK INK
  945. CASE TYPE('INK')='C'
  946.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  947.   PC=REPL('X',LEN(INK))
  948.   @ 24,0 SAY 'Seek ' GET INK PICT '&PC'
  949.   READ
  950.   SEEK trim(INK)
  951. CASE TYPE('INK')='D'
  952.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  953.   @ 24,0 SAY 'Seek ' GET INK PICT '@D'
  954.   READ
  955.   SEEK INK
  956. ENDC
  957. RESTORE SCREEN FROM GENSEEK1
  958. RETU
  959.  
  960. PROCEDURE FORMFEED
  961. * Syntax:  DO FORMFEED
  962. * Notes.:  Assumes a public variable OUTPUT declared as character
  963. *
  964. DO CASE
  965. CASE OUTPUT='S'
  966.   IF PAUSE
  967.     DO CNTR WITH 'Hit a key'
  968.     inkey(0)
  969.   ENDIF
  970.   CLEA
  971. CASE OUTPUT = 'D'
  972.   ?? chr(12)
  973. CASE OUTPUT = 'P'
  974.   EJEC
  975. ENDC
  976. RETU
  977.  
  978. FUNCTION ULEN
  979. * Syntax: ULEN ( <ExpC> )
  980. * Return: The length of any variable (variable name is passed as character),
  981. *         0 if undefined variable
  982. *
  983. PARA var
  984. IF TYPE('Var') # 'U'
  985.   DO CASE
  986.   CASE TYPE(Var)='N'
  987.     RETURN (len(str(&var)))
  988.   CASE TYPE(Var)='L'
  989.     RETURN (3)
  990.   CASE TYPE(Var) $ 'MC'
  991.     RETURN (Len(&var))
  992.   CASE TYPE(Var)='D'
  993.     RETURN (8)
  994.   OTHERWISE
  995.     RETURN (0)
  996.   ENDCASE
  997. ELSE
  998.   RETURN (0)
  999. ENDIF
  1000.  
  1001. PROCEDURE CNTR
  1002. * Syntax:  DO CNTR WITH <Text>, [<Line>]
  1003. * Notes.:  Centers <Text> on <Line>.  <Line> defaults to 0
  1004. *
  1005. PARA Text,Line
  1006. IF Pcount()<2
  1007.   Line=0
  1008. ENDIF
  1009. @ Line,40-len(text)/2 SAY text
  1010. RETU
  1011.  
  1012. PROCEDURE CORRECT
  1013. * Syntax:  DO CORRECT
  1014. * Notes.:  Assumes a public variable COR.  Changes COR to .F. if the current
  1015. *          GET variables have been updated, then prompts for correctness.
  1016. *
  1017. Cor=IF(UPDATED(),.N.,.T.)
  1018. @ 24,0
  1019. @ 24,0 SAY 'Is everything correct (Y\N) ? ' GET Cor
  1020. READ
  1021. @ 24,0
  1022. RETU
  1023.  
  1024. PROCEDURE STATUS
  1025. * Syntax:  DO STATUS
  1026. * Notes.:  Closest emulation of dBASE's DISPLAY STATUS I could think of
  1027. *
  1028. PRIV Ret_Area,Cur_AREA,i,J,K
  1029. SAVE SCREEN TO STAT1
  1030. IF Empty(Alias())
  1031.   @ 24,0 SAY 'No files in use.'
  1032.   inkey(0)
  1033. ENDIF
  1034. @ 0,0 CLEA
  1035. Ret_Area=ALIAS()
  1036. ? 'Current work area: ',Ret_Area
  1037. ? 'Current index key: ',IndexKey(0)
  1038. K=0
  1039. FOR I=1 to 10
  1040.   IF ! EMPTY(Alias(I))
  1041.     K=K+1
  1042.     IF K>3
  1043.       K=0
  1044.       inkey(0)
  1045.     ENDIF
  1046.     Cur_Area=Alias(I)
  1047.     SELE &Cur_Area
  1048.     ? 'Work area',str(i,2),'database:',Alias(I)
  1049.     ? 'Number of records:',reccount()
  1050.     ? 'Current record:   ',recno()
  1051.     ? 'Master index key: ',INDEXKEY(0)
  1052.     FOR J=1 to 7
  1053.       IF ! Empty(Index(J))
  1054.         ? 'Index',str(j,2),'key:',INDEXKEY(J)
  1055.       ENDIF
  1056.     NEXT
  1057.     ?
  1058.   ENDIF
  1059. NEXT
  1060. inkey(0)
  1061. SELE &Ret_Area
  1062. @ 0,0 CLEA
  1063. ? 'Operating system:  DOS',OS()
  1064. ? 'System memory:    ',SysMem()
  1065. ?? 'K'
  1066. ? 'Free memory:      ',Fre(),'Bytes'
  1067. ? 'Current drive:    ',Curr_Drive()
  1068. ? 'Current directory:',Curr_dir()
  1069. ? 'Current date:     ',CDOW(Date())+',',DTOW(Date())
  1070. ? 'Current time:     ',AMPM(Time())
  1071. ? 'Video page:       ',Get_Page()
  1072. ? 'Video mode:       ',Get_Mode()
  1073. ?
  1074. i='I'
  1075. DO WHIL ! EMPTY(I)
  1076.   ACCEPT 'Expression to evaluate: ' TO I
  1077.   IF ! EMPTY(I)
  1078.     ? i,':',&i
  1079.   ENDIF
  1080. ENDDO
  1081. RESTORE SCREEN FROM STAT1
  1082. RETU
  1083.  
  1084. PROCEDURE PACKEM
  1085. * Syntax:  DO PACKEM
  1086. * Notes.:  Will use DELCOUNT() to count the deleted records in the file if
  1087. *          RecCount()<1000, otherwise prompts for it.  Prompts for Packing.
  1088. *
  1089. PRIV BP
  1090. DO COL1
  1091. IF EMPTY(Alias())
  1092.   DO CNTR WITH 'No file in use',0
  1093.   inkey(0)
  1094.   @ 0,0
  1095. ENDIF
  1096. CLEA
  1097. DO TITLE WITH 'Packing the '+Alias()+' datafile'
  1098. DO BOXIT WITH 4,10,8,70
  1099. BP=RecCount()
  1100. Cor=.Y.
  1101. IF BP>1000
  1102.   @ 24,0 SAY ltrim(str(BP))+' records. Count deleted ones (Y/N)? ' GET Cor
  1103.   READ
  1104.   @ 24,0
  1105. ENDIF
  1106. IF Cor
  1107.   @ 5,22 SAY 'Records to remove:  '
  1108.   K=DelCount()
  1109.   ?? ltrim(str(K))
  1110. ELSE
  1111.   K=1
  1112. ENDIF
  1113. DO CNTR WITH 'Packing '+Alias()+' will remove all deleted records.',7
  1114. IF K>0
  1115.   Cor=.Y.
  1116.   @ 6,22 SAY 'Go ahead and pack (Y/N)? ' GET Cor
  1117.   READ
  1118.   IF Cor
  1119.     PACK
  1120.     DO OOPS WITH ltrim(str(BP-RecCount()))+' records removed.'
  1121.   ENDIF
  1122. ELSE
  1123.   inkey(0)
  1124. ENDIF
  1125. RETU
  1126.  
  1127. PROCEDURE SETFILT
  1128. * Syntax:  DO SETFILT
  1129. * Notes.:  Allows you to set a filter with limited help. Assumes public
  1130. *          FiltCond
  1131. *
  1132. IF EMPTY(Alias())
  1133.   DO CNTR WITH 'No file selected',24
  1134.   inkey(0)
  1135.   RETU
  1136. ENDIF
  1137. IF TYPE('FiltCond')='C'
  1138.   @ 12,0 SAY 'Current filter: '+FiltCond
  1139.   Cor=.Y.
  1140.   @ 24,0 SAY 'Use current filter (Y\N)? ' GET Cor
  1141.   READ
  1142.   IF Cor
  1143.     RETU
  1144.   ENDIF
  1145. ELSE
  1146.   FiltCond=space(140)
  1147. ENDIF
  1148. Ans=1
  1149. DECL FI[1]
  1150. FI[1]=space(11)
  1151. DO COL1
  1152. CLEA
  1153. DO WHIL ANS#0
  1154.   @ 1, 0 PROMPT 'Edit'  MESSAGE 'Edit the filter'
  1155.   @ 1,10 PROMPT 'Field' MESSAGE 'Select a field'
  1156.   @ 1,20 PROMPT 'Help'  MESSAGE 'Get help in creating filter'
  1157.   @ 1,30 PROMPT 'Quit'  MESSAGE 'Filter is finished'
  1158.   MENU TO ANS
  1159.   DO CASE
  1160.   CASE Ans = 1
  1161.     @ 22,0 SAY CLS()
  1162.     @ 22,0 SAY 'Filter: ' GET FiltCond
  1163.     READ
  1164.   CASE Ans = 2
  1165.     SAVE SCREEN TO FILT1
  1166.     DO SELEFIELDS WITH FI,FCount()
  1167.     RESTORE SCREEN FROM FILT1
  1168.     FiltCond=untrim(trim(FiltCond)+FI[1],140)
  1169.     @ 22,0 SAY CLS()
  1170.     @ 22,0 SAY 'Filter: '
  1171.     DO COL2
  1172.     ?? FiltCond
  1173.     DO COL1
  1174.     KEYBOARD 'E'+chr(6) && end key
  1175.   CASE Ans = 3
  1176.     SAVE SCREEN TO FILT1
  1177.     @ 0,0 CLEA
  1178.     DO BOXIT WITH 0,0,15,79
  1179.     DO CNTR WITH 'Conditions                       Common functions                ',1
  1180.     DO CNTR WITH '!     negates                    str(pi,4,2)       = "3.14", etc.',2
  1181.     DO CNTR WITH '.NOT. negates                    dtoc(Christmas)   = "12/25/87"  ',3
  1182.     DO CNTR WITH '.AND.                            dtos(Christmas)   = "19871225"  ',4
  1183.     DO CNTR WITH '.OR.                             ctod("12/25/87")  = Christmas   ',5
  1184.     DO CNTR WITH '()    nest conditions            upper("John")     = "JOHN"      ',6
  1185.     DO CNTR WITH '$     text string contained in   left("12345",2)   = "12"        ',7
  1186.     DO CNTR WITH '#     not equal to               right("12345",2)  = "45"        ',8
  1187.     DO CNTR WITH '<,>,= same meanings              substr("123",2,1) = "2"         ',9
  1188.     DO CNTR WITH 'Examples',11
  1189.     DO CNTR WITH '"JOHN" $ UPPER(First)              means "is JOHN in First"      ',12
  1190.     DO CNTR WITH 'Datefield > CTOD("12/25/87")       means "Datefield > Christmas" ',13
  1191.     DO CNTR WITH '(N1 > N2) .AND. (N4 = N3)                                        ',14
  1192.     inkey(0)
  1193.     RESTORE Screen FROM FILT1
  1194.     KEYBOARD 'E'+chr(6) && end key
  1195.   CASE Ans = 4
  1196.     Ans = 0
  1197.   ENDC
  1198. ENDDO
  1199. IF ! EMPTY(FiltCond) .AND. Type(FiltCond)='L'
  1200.   SET FILT TO &FiltCond
  1201. ENDIF
  1202. RETU
  1203.  
  1204. PROCEDURE OPCHOICE
  1205. * Syntax:  DO OPCHOICE
  1206. * Notes.:  Determines where output is going: Disk, Printer, or Screen
  1207. *          Assumes a public character variable called OUTPUT for other
  1208. *          procedures such as PrintOn, PrintOff, and FormFeed
  1209. PRIVATE ANSWER
  1210. ANSWER=0
  1211. @ 23,0 CLEA
  1212. @ 23,0  PROMPT 'Printer' MESSAGE 'Select output to the printer'
  1213. @ 23,10 PROMPT 'Screen' MESSAGE 'Select output to the screen'
  1214. @ 23,20 PROMPT 'Disk' MESSAGE 'Select output to a disk file'
  1215. @ 23,30 PROMPT 'Quit' MESSAGE "Don't select an output device and quit"
  1216. MENU TO ANSWER
  1217. @ 23,0 CLEA
  1218. DO CASE
  1219. CASE ANSWER=1
  1220.   OUTPUT='P'
  1221. CASE ANSWER=2
  1222.   OUTPUT='S'
  1223.   Pause=.F.
  1224.   @ 23,0 SAY 'Pause for each page (Y/N)? ' GET Pause
  1225.   READ
  1226. CASE ANSWER=3
  1227.   OUTPUT='D'
  1228.   * sets up the alternate file to a disk file name after verifying
  1229.   * an overwrite if the file exists
  1230.   Cor=.N.
  1231.   File=space(20)
  1232.   DO SELEFILE WITH '*.TXT',File,.N.,'Select a file for output. "*" in filename for a new directory'
  1233.   IF ! EMPTY(File)
  1234.     SET ALTE TO &File
  1235.   ELSE
  1236.     OUTPUT='S'
  1237.   ENDIF
  1238. ENDC
  1239. RETU
  1240.  
  1241. FUNC ZERO
  1242. * Syntax:  Zero( <ExpN1>, <ExpN2> )
  1243. * Notes.:  Returns <ExpN1>/<ExpN2> if <ExpN2>#0, otherwise 0
  1244. PARA ZN1,ZN2
  1245. IF PCOUNT()<2
  1246.   RETURN (0)
  1247. ENDIF
  1248. IF ZN2=0
  1249.   RETURN (0)
  1250. ENDIF
  1251. RETURN ( ZN1/ZN2)
  1252.  
  1253. FUNC SZERO
  1254. * Syntax:  Sero( <ExpN1>, <ExpN2> )
  1255. * Notes.:  Returns string of Zero(<ExpN1>,<ExpN2>)
  1256. PARA ZN1,ZN2
  1257. IF PCOUNT()<2
  1258.   RETURN ('')
  1259. ENDIF
  1260. RETURN ( ZERO(ZN1,ZN2) )
  1261.  
  1262. PROCEDURE INITVARS
  1263. * Syntax:  DO INITVARS
  1264. * Notes.:  Copies the data from the current record to a new record
  1265. *
  1266. PRIV I,FN
  1267. IF RecCount()=0
  1268.   APPE BLAN
  1269.   RETURN
  1270. ENDIF
  1271. FOR I=1 TO FCOUNT()
  1272.   FN=Field(I)
  1273.   M->&FN = &FN
  1274. NEXT
  1275. APPE BLAN
  1276. FOR I=1 TO FCOUNT()
  1277.   FN=Field(I)
  1278.   REPL &FN WITH M->&FN
  1279. NEXT
  1280. RETU
  1281.  
  1282. PROCEDURE EXECMAC
  1283. * Syntax:  DO ExecMac
  1284. * Notes.:  Executes a specified HP Laserjet Macro a specified # of times
  1285. *          This assumes that you have my library, HPLJLIB.PRG
  1286. PRIV I,J,K
  1287. I=1
  1288. K=1
  1289. DO COL1
  1290. CLEA
  1291. DO TITLE WITH 'Executing an HP LaserJet Plus Macro'
  1292. DO BOXIT WITH 4,20,8,60
  1293. DO CNTR WITH 'The program assumes that the macro is already correctly loaded',10
  1294. DO CNTR WITH 'into the LaserJet Plus RAM.',12
  1295. Cor=.N.
  1296. DO WHIL ! Cor
  1297.   @ 5,22 SAY 'Macro to Execute ' GET I PICT '9999'
  1298.   @ 7,22 SAY '# of repetitions ' GET K PICT '999'
  1299.   READ
  1300.   IF Empty(I).AND.Empty(K)
  1301.     RETU
  1302.   ENDIF
  1303.   DO CORRECT
  1304. ENDDO
  1305. DO CNTR WITH 'Executing the macro '+alltrim(str(K))+' times.  <Esc> to abort.',23
  1306. SET PRIN ON
  1307. SET CONS OFF
  1308. SET PRIN ON
  1309. SET CONS OFF
  1310. J=1
  1311. Key=0
  1312. DO WHIL J<=K.AND.Key#27
  1313.   Key=inkey()
  1314.   IF Key#27
  1315.     ?? HPEmac(I)
  1316.   ENDIF
  1317.   J=J+1
  1318. ENDDO
  1319. SET PRIN OFF
  1320. SET CONS ON
  1321. RETU
  1322.  
  1323. * These procedures are also generated by my program CLIPMENU.COM
  1324.  
  1325. PROC BOXCOL
  1326. * Syntax:  DO BOXCOL
  1327. * Notes.:  Sets the box color for color or monochrome systems
  1328. IF ISCOLOR()
  1329.   SET COLO TO GR/N
  1330. ELSE
  1331.   SET COLO TO W/N
  1332. ENDIF
  1333. RETU
  1334.  
  1335. PROC COL1
  1336. * Syntax:  DO COL1
  1337. * Notes.:  Sets the normal screen for color or monochrome systems
  1338. IF ISCOLOR()
  1339.   SET COLO TO GR+/N,W+/B,,,W/B
  1340. ELSE
  1341.   SET COLO TO W+/N,N/W,,,B/N
  1342. ENDIF
  1343. RETU
  1344.  
  1345. PROC COL2
  1346. * Syntax:  DO COL2
  1347. * Notes.:  Sets the inverse (GET field) screen for color or monochrome systems
  1348. IF ISCOLOR()
  1349.   SET COLO TO W/B
  1350. ELSE
  1351.   SET COLO TO B/N
  1352. ENDIF
  1353. RETU
  1354.  
  1355. PROC BOXIT
  1356. * Syntax.: DO BOXIT WITH <Top>, <Left>, <Bottom>, <Right>, <Border>, <Clear>
  1357. * Notes..: Creates a box at the above locations with <Border>
  1358. *
  1359. PARAMETERS Top,Left,Bottom,Right,Border,Clear
  1360. IF TYPE("Border")#"N"
  1361.   Border=1
  1362. ENDIF
  1363. IF TYPE("Right")#"N".OR.TYPE("Left")#"N".OR.TYPE("Top")#"N".OR.TYPE("Bottom")#"N"
  1364.   RETURN
  1365. ENDIF
  1366. DO CASE
  1367. CASE Border=0
  1368.   Bframe = "        "
  1369. CASE Border=2
  1370.   BFrame = "╔═╗║╝═╚║"
  1371. CASE Border=3
  1372.   BFrame = "╒═╕│╛═╘│"
  1373. CASE Border=4
  1374.   BFrame = "╓─╖║╜─╙║"
  1375. CASE Border=5
  1376.   BFrame = "▄▄▄█▀▀▀█"
  1377. CASE Border=6
  1378.   BFrame = "▄▄▄▐▀▀▀▌"
  1379. CASE Border=7
  1380.   BFrame = "████████"
  1381. CASE Border=8
  1382.   BFrame = "▓▓▓▓▓▓▓▓"
  1383. CASE Border=9
  1384.   BFrame = "▒▒▒▒▒▒▒▒"
  1385. CASE Border=10
  1386.   BFrame = "░░░░░░░░"
  1387. CASE Border=11
  1388.   BFrame = "┌ ┐│╛═╘│"
  1389. OTHE
  1390.   Bframe = "┌─┐│┘─└│"
  1391. ENDC
  1392. IF TYPE("Clear")="C"
  1393.   Bframe=Bframe+Clear
  1394. ENDIF
  1395. DO BOXCOL
  1396. @ Top,left CLEA TO Bottom,Right
  1397. IF Border#0
  1398.   @ Top,left,bottom,right BOX Bframe
  1399. ENDIF
  1400. DO COL1
  1401. RETU
  1402. * EOP: Procedure BOXIT
  1403.  
  1404.  
  1405. *************************
  1406. *  External declarations:
  1407. *************************
  1408.  
  1409. ** These external utilities are from DL1B.ARC - if you don't have it, get it!
  1410.  
  1411. EXTERNAL untrim,dtow,getkey, dial, set_page, reset, prtscr, get_mode
  1412. EXTERNAL get_page, chdir, mkdir, rmdir, set_mode, sysmem, cursor, cls
  1413. EXTERNAL curr_drive, set_time, curr_dir, set_date, setdate, set_drive, subset
  1414. EXTERNAL isupper, islower, ltow, subsets, os, allalpha, allnum, allascii, fre
  1415. EXTERNAL timeh, isdir, dl_version, csr_top, csr_bot, isprint
  1416.  
  1417. * EOP: EXTENDB2.PRG
  1418.