home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / EXTNDB23.ZIP / EXTENDB2.PRG next >
Encoding:
Text File  |  1987-07-22  |  46.9 KB  |  1,905 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. *           ASRCH()       ::= Returns closest value to a target in a sorted array
  25. *           CONFIRM()     ::= Y/N, T/F question without READ
  26. *           CSTRING()     ::= character string of any data type
  27. *           DEFAULT()     ::= Gives a variable a default value
  28. *           DELCOUNT()    ::= # of records marked for deletion in current file
  29. *           DIV()         ::= integer division of n1 by n2
  30. *           EDFUNC()      ::= My editor function for DBEDIT in DBU.LIB
  31. *           FEXISTS()     ::= T/F if file with/without extension exists
  32. *           FIELDNUM()    ::= # of 'field' in currently used file
  33. *           FRAME()       ::= Border type for boxes
  34. *           ISFOUND()     ::= Is target in index
  35. *           JUSTIFY()     ::= space(difference b/n Field Length & Field Name)
  36. *           KNT()         ::= # of times a string occurs in Mem/Char field + 1
  37. *           LOGIC()       ::= Any part of 'Yes' or 'No ' value of logic variable
  38. *           OS()          ::= Tom Rettig's DOSVERS()
  39. *           PERC()        ::= 100 * Num1/Num2
  40. *           RITE()        ::= string of any variable, with two options
  41. *           SPERC()       ::= string of PERC()
  42. *           SZERO()       ::= string(Zero())
  43. *           ULEN()        ::= length of any type of variable
  44. *           VALDIR()      ::= is directory valid?
  45. *           ZERO()        ::= n1/n2 if n2#0, otherwise 0
  46. *
  47. *           PROCEDURES
  48. *           ALIST      ::= print out array
  49. *           ASORT      ::= Sort an array of one type in A/D order
  50. *           BOXCOL     ::= Set the color for box frames
  51. *           BOXIT      ::= Draw a box on the screen
  52. *           CNTR       ::= Center text on a line
  53. *           COL1       ::= Set the normal screen colors
  54. *           COL2       ::= Set inverse screen colors for displaying GET fields
  55. *           COPYVARS   ::= Copy data from current record to new record
  56. *           CORRECT    ::= If get variables were updated, asks if correct
  57. *           FORMFEED   ::= Form feed for whatever output you have
  58. *           GENSEEK    ::= Generic seeking procedure (any index!)
  59. *           INDEX      ::= Revised Nantucket index.PRG
  60. *           INITVARS   ::= Initialize X<FieldName> memory vars from record
  61. *           INSTALL    ::= Generic installation procedure
  62. *           LISTRECS   ::= List records to the screen
  63. *           OOPS       ::= Flashing message centered on line 0
  64. *           OPCHOICE   ::= Select an output device and set it
  65. *           OPTIONS    ::= Options for EDFUNC()
  66. *           PACKEM     ::= generic pack utility
  67. *           PRINTOFF   ::= Output redirection procedure
  68. *           PRINTON    ::= Output redirection procedure
  69. *           REPLVARS   ::= Replace record with memory variable values
  70. *           RESETINDEX ::= Generic index (re)setter
  71. *           SELEFIELDS ::= Select fields from the current database
  72. *           SELEFILE   ::= Select a file from the current subdirectory
  73. *           SELEREC    ::= Select a record in a file
  74. *           SETFILT    ::= Set a filter
  75. *           SHOWCLIP   ::= Show status of Clipper environment
  76. *           SHOWFIELDS ::= Show the fields in the currently selected database
  77. *           SHOWFILES  ::= Display the files on current subdirectory
  78. *           SHOWREC    ::= Shows list of fields at x,y w/ separator
  79. *           SHOWSYS    ::= Display the DOS system configuration
  80. *           STATS      ::= Closest I could get to dB3's display status
  81. *           TITLE      ::= Make a title on the screen
  82. *
  83. * Warnings: I recently optimized this since I got Tom Rettig's library for
  84. *           Clipper, so some of the utilities that I used to have in here
  85. *           I got rid of because his "C" or Assembler source code is faster.
  86. *           If I inconvenience anyone by removing my slower Clipper-coded
  87. *           routines, sorry . . . but these are MY routines, and I'll do what
  88. *           conveniences me the most with them.  Also, any serious Clipper
  89. *           programmer should get Tom Rettig's library, anyway.  The external
  90. *           routines listed on the bottom of this file and used in some of
  91. *           my routines are from Dirk Lesko's library (DL1B.ARC).  Probably
  92. *           any bulletin board you got this from will have them.  If not,
  93. *           try Rockland in New York, Exec-PC in Milwaukee, Darwin in D.C.,
  94. *           or Acumen in Virginia.
  95. *
  96. *           You can obtain a copy of Tom Rettig's Library from:
  97. *               Tom Rettig Associates
  98. *               9300 Wilshire Boulevard, Suite 470
  99. *               Beverly Hills, California  90212-3237
  100. *               (213) 272-3784
  101. *
  102.  
  103. FUNCTION DIV
  104. * Syntax:  DIV( <ExpN1>, <ExpN2> )
  105. * Notes.:  Returns int(<ExpN1>/<ExpN2>) if <ExpN2>#0, otherwise 0
  106. PARA ZN1,ZN2
  107. IF PCOUNT()<2
  108.   RETURN (0)
  109. ENDIF
  110. IF ZN2=0
  111.   RETURN (0)
  112. ENDIF
  113. RETURN ( INT(ZN1/ZN2))
  114.  
  115. FUNCTION DELCOUNT
  116. * Syntax.: Delcount ( [<ExpC>] )
  117. * Returns: Number of records marked for deletion in the <ExpC> or current file
  118. *
  119. PARA D_File
  120. PRIV K,RetArea
  121. RetArea=ALIAS()
  122. IF PCOUNT()>0
  123.   IF TYPE('D_File')='C'
  124.     SELE &D_File
  125.   ENDIF
  126. ENDIF
  127. SET DELE OFF
  128. COUN FOR DELETED() TO K
  129. SET DELE ON
  130. SELE &RetArea
  131. RETURN (K)
  132.  
  133. FUNCTION FIELDNUM
  134. * Syntax: FIELDNUM( <ExpC> )
  135. * Return: The field number of <ExpC> in current DBF, or '0' if not found
  136. *
  137. PARAMETERS fldname
  138. PRIVATE Kount,fit
  139. KOUNT=1
  140. fit=0
  141. DO WHILE field(KOUNT)>' '.AND.fit=0
  142.   IF trim(field(KOUNT))=trim(fldname)
  143.     fit=Kount
  144.   ENDIF
  145.   KOUNT=KOUNT+1
  146. ENDDO
  147. RETURN (fit)
  148.  
  149. FUNCTION JUSTIFY
  150. * Syntax: JUSTIFY ( <Exp?> )
  151. * Return: Number of spaces = the difference in Length b/n name of variable and
  152. *         its contents
  153. PARAMETERS Width
  154. PRIVATE Difference
  155. IF TYPE('Width')='U'
  156.   RETURN ('')
  157. ELSE
  158.   Difference=len(Width)-ulen(Width)
  159.   RETURN (space(abs(Difference)))
  160. ENDIF
  161.  
  162. FUNCTION Logic
  163. * Syntax.: LOGIC( <ExpL>, [<length>] )
  164. * Return.: The leftmost <ExpN> of 'Yes' or 'No ', or 'Yes' or 'No ' + <length>
  165. *          minus 3 spaces
  166. * Default: <length> = 3
  167. PARA YN,Lnth
  168. PRIV st
  169. IF Type('Lnth')='U'
  170.   Lnth=3
  171. ENDIF
  172. IF YN
  173.   st='Yes'
  174. ELSE
  175.   st='No '
  176. ENDIF
  177. IF Lnth>3
  178.   RETURN (st+space(Lnth-3))
  179. ELSE
  180.   RETURN (LEFT(st,Lnth))
  181. ENDIF
  182.  
  183. FUNCTION PERC
  184. * Syntax.: PERC( <ExpN1> , <ExpN2> )
  185. * Return.: 100 * <ExpN1> / <ExpN2>
  186. PARA Made,Att
  187. IF Type('Made')<>'N'.OR.Type('Att')<>'N'
  188.   RETURN(0)
  189. ELSE
  190.   RETURN(100*ZERO(Made,Att))
  191. ENDIF
  192.  
  193. FUNCTION SPERC
  194. * Syntax.: SPERC( <ExpN1> , <ExpN2> , [<width>,[<decimal>]] )
  195. * Return.: str(100 * <ExpN1>/<ExpN2>,<width>,<decimal>)
  196. * Default: <width> = 7, <decimal> = 3
  197. PARA Made,Att,Wid,Dec
  198. IF type('Dec') # 'N'
  199.   Dec=3
  200. ENDIF
  201. IF Type('Wid') # 'N'
  202.   Wid=7
  203. ENDIF
  204. IF Type('Made')<>'N'.OR.Type('Att')<>'N'
  205.   RETURN(repl('*',wid))
  206. ELSE
  207.   RETURN(str(PERC(Made,Att),Wid,Dec))
  208. ENDIF
  209.  
  210. FUNCTION Rite
  211. * Syntax.: RITE( <Exp?>, [<Delimiter>] )
  212. * Returns: A character string of <Exp?> either len(<Exp?>) long or the
  213. *          "ALLTRIM( <Exp?> )"
  214. * Default: <Delimiter> = ''
  215. * Notes..: WPSTRIP is from Tom Rettig's library.  I used it because the
  216. *          C source code is faster than my Clipper version.  If you don't
  217. *          have WPSTRIP, look at my MEMOUTIL library's MEMOREPL or LINEWRAP
  218. *          functions.
  219. PARA FldName,Delim
  220. PRIV St
  221. IF Type('Delim') # 'C'
  222.   Delim=''
  223. ENDIF
  224. DO CASE
  225. CASE Delim='D'
  226.   DO CASE
  227.   CASE TYPE(FldName)='D'
  228.     st=DTOC(&FldName)
  229.   CASE TYPE(FldName)='N'
  230.     st=ltrim(str(&FldName))
  231.   CASE TYPE(FldName)='L'
  232.     st=trim(logic(&FldName))
  233.   CASE TYPE(FldName)='M'
  234.     st=trim(WPSTRIP(FldName))
  235.   OTHERWISE
  236.     st=Alltrim(&FldName)
  237.   ENDCASE
  238.   st='"'+st+'"'
  239. OTHERWISE
  240.   DO CASE
  241.   CASE TYPE(FldName)='D'
  242.     st=DTOC(&FldName)
  243.   CASE TYPE(FldName)='N'
  244.     st=str(&FldName)
  245.   CASE TYPE(FldName)='L'
  246.     st=logic(&FldName)
  247.   CASE TYPE(FldName)='M'
  248.     st=WPStrip(FldName)
  249.   OTHERWISE
  250.     st=&FldName
  251.   ENDCASE
  252. ENDCASE
  253. RETURN (st)
  254.  
  255. FUNCTION CSTRING
  256. * Syntax.:  CSTRING ( <Exp?> )
  257. * Returns:  Character string of any data type
  258. PARA S
  259. IF PCOUNT()<1
  260.   RETURN ( "" )
  261. ENDIF
  262. DO CASE
  263. CASE TYPE('S')='U'
  264.   RETURN ( "" )
  265. CASE TYPE('S')='L'
  266.   RETURN ( IF(S,'Yes','No ') )
  267. CASE TYPE('S')='D'
  268.   RETURN ( SUBSTR(CMONTH(S),1,3) )
  269. CASE TYPE('S')='N'
  270.   RETURN ( STR(S) )
  271. ENDC
  272. RETURN ( S )
  273.  
  274. FUNCTION Knt
  275. * Syntax.: KNT( <ExpM>, [<separator>] )
  276. * Return.: Number of words, or # of occurences of [<separator>] in <ExpM>
  277. * Default: <Separator> = space(1)
  278. PARA Targ,Sep
  279. IF Type('Sep') # 'C'
  280.   Sep=' '
  281. ENDIF
  282. PRIV Kount,St
  283. Kount=0
  284. St=Targ
  285. IF Type('Targ')$'CM'
  286.   DO WHILE AT(sep,st)>0
  287.     Kount=Kount+1
  288.     st=Right(st,len(st)-at(sep,st)-len(sep)+1)
  289.     IF AT(sep,st)=1
  290.       DO WHILE AT(Sep,st)=1
  291.         st=Right(st,len(st)-at(sep,st)-len(sep)+1)
  292.       ENDDO
  293.     ENDIF
  294.   ENDDO
  295.   IF sep=' '
  296.     Kount=Kount+1
  297.   ENDIF
  298. ENDIF
  299. RETURN (Kount)
  300.  
  301. PROCEDURE SHOWFIELDS
  302. * Syntax: DO SHOWFIELDS
  303. * Notes.: Displays the fields in the currently selected database
  304. PRIV I,FSTOP
  305. FSTOP=FCOUNT()
  306. BotLine=6+DIV(FSTOP,6)
  307. DO BOXIT WITH 4,0,BotLine,79,1
  308. FOR I=1 TO FSTOP
  309.  DO COL1
  310.  @ 5+DIV(I-1,6),5+MOD(i-1,6)*12 SAY type(Field(I))
  311.  DO COL2
  312.  ?? FIELD(I)
  313. NEXT
  314. DO COL1
  315. RETURN
  316.  
  317. PROCEDURE SELEFIELDS
  318. * Syntax: DO SELEFIELDS
  319. * Notes.: Calls SHOWFIELDS, then allows you to select any and all fields in
  320. *         the file and returns the field list in the array FLIST
  321. *         Possible problems - does not detect for doubled variable selection,
  322. *         because I didn't want to - maybe someone wants to use a field twice
  323. PARA FLIST,FNUM
  324. IF EMPTY(Alias())
  325.   DO OOPS WITH 'No file has been selected'
  326.   RETU
  327. ENDIF
  328. IF PCOUNT()<1
  329.   DO OOPS WITH 'An array must be passed to SELEFIELDS'
  330.   RETU
  331. ENDIF
  332. IF PCOUNT()<2
  333.   FNUM=FCOUNT()
  334. ENDIF
  335. IF TYPE('FLIST')#'A'
  336.   DO OOPS WITH 'An array must be passed to SELEFIELDS'
  337.   RETU
  338. ENDIF
  339. PRIV Row,Col,LastLine,I,J
  340. DO COL1
  341. CLEA
  342. DO TITLE WITH 'Selecting fields from '+ALIAS()
  343. DO SHOWFIELDS
  344. i=1
  345. FStop=Fcount()
  346. IF DIV(FStop,6)=1
  347.   LastLine=1
  348. ELSE
  349.   LastLine=DIV(FStop,6)+1
  350. ENDIF
  351. @ 23,0 SAY 'Fields'
  352. SET COLO TO W+
  353. key=0
  354. FNUM=0
  355. DO WHIL key#27
  356.   SET COLO TO W+
  357.   @ 5+DIV(I-1,6),4+MOD(I-1,6)*12 SAY ''
  358.   key=inkey(0)
  359.   @ 5+DIV(I-1,6),4+MOD(I-1,6)*12 SAY ' '
  360.   DO COL1
  361.   DO CASE
  362.   Case Key=HelpKey
  363.     @ 0,0 SAY 'Move: arrows, [Home], [End]; [Enter] selects field, [D]elete field, [Esc] leaves'
  364.   CASE Key=LfArrow
  365.     i=IF(I>1,i-1,i)
  366.   CASE Key=RtArrow
  367.     i=IF(i<FStop,i+1,i)
  368.   CASE Key=HomeKey
  369.     i=1
  370.   CASE Key=EndKey
  371.     I=FCount()
  372.   CASE Key=UpArrow
  373.     i=IF(i-6>1,i-6,1)
  374.   CASE Key=DnArrow
  375.     i=if(I+6<Fcount(),i+6,Fcount())
  376.   CASE (Key=68.OR.Key=100).AND.FNUM>0 && D or d
  377.     FLIST[FNUM]=.F.
  378.     FNUM=FNUM-1
  379.     @ 23,7
  380.     @ 24,0
  381.     IF FNUM>0
  382.       DO COL2
  383.       @ 23,7 SAY FLIST[1]
  384.       FOR J = 2 to FNUM
  385.         ?? ','+trim(FLIST[J])
  386.       NEXT
  387.       DO COL1
  388.     ENDIF
  389.   CASE Key=13
  390.     IF FNUM<FCOUNT()
  391.       FNUM=FNUM+1
  392.       FLIST[FNUM]=FIELD(I)
  393.       i=IF(i<Fstop,i+1,1)
  394.       @ 23,7
  395.       DO COL2
  396.       @ 23,7 SAY FLIST[1]
  397.       FOR J = 2 to FNUM
  398.         ?? ','+trim(FLIST[J])
  399.       NEXT
  400.       DO COL1
  401.     ELSE
  402.       DO OOPS WITH 'Attempted to select more fields than there are.'
  403.     ENDIF
  404.   ENDC
  405. ENDDO
  406. RETU
  407.  
  408. FUNC FExists
  409. * Syntax: FExists ( <ExpC>, [<Ext>] )
  410. * Return: .T. if <ExpC> empty or it exists, .F. if not
  411. PARA File,Ext
  412. IF PCOUNT()<1
  413.   RETURN ( .T. )
  414. ENDIF
  415. IF PCOUNT()<2
  416.   Ext='.'
  417. ELSE
  418.   IF TYPE('Ext')='C'
  419.     Ext='.'+alltrim(Ext)
  420.   ELSE
  421.     Ext='.'
  422.   ENDIF
  423. ENDIF
  424. IF ! EMPTY(File)
  425.   RETURN ( File (IF(AT('.',File)=0,trim(File)+Ext,file)) )
  426. ENDIF
  427. RETURN ( .T. )
  428.  
  429. PROCEDURE SHOWFILES
  430. * Syntax:  DO SHOWFILES WITH [<Mask> [,<Array of Files> [,<# of Files> [,<Title>]]]]
  431. * Notes.:  Returns the list of files in <Array of Files>
  432. PARA Mask,Files,Num,Title
  433. IF PCOUNT()<1
  434.   Mask='*.*'
  435. ENDIF
  436. IF TYPE('Mask')#'C'
  437.   Mask='*.*'
  438. ENDIF
  439. IF PCOUNT()<2
  440.   DECLARE FILES[ADIR(Mask)]
  441. ENDIF
  442. IF TYPE('FILES')#'A'
  443.   DECLARE FILES[ADIR(MASK)]
  444. ENDIF
  445. IF PCOUNT()<3
  446.   Num=ADIR(Mask,Files)
  447. ENDIF
  448. IF TYPE('Num')#'C'
  449.   Num=ADIR(Mask,Files)
  450. ENDIF
  451. DO ASort WITH Files,'A'
  452. IF TYPE('Title')#'C'
  453.   Title='Directory of '+trim(Mask)+' Files'
  454. ENDIF
  455. DO COL1
  456. CLEA
  457. DO TITLE WITH Title
  458. DO BOXIT WITH 3,0,5+DIV(Num-1,5),79
  459. FOR I = 1 to num
  460.   @ 4+DIV(I-1,5),5+MOD(i-1,5)*14 SAY Files[I]
  461. NEXT
  462. RETU
  463.  
  464. PROCEDURE SELEFILE
  465. * Syntax:  DO SHOWFILES WITH [<Mask>],[<FName>],[<Must exist?>],[<Title>]
  466. * Notes.:  Returns the name of the file selected.  Calls SHOWFILES
  467. PARA Mask,Selected,MustExist,Title
  468. PRIV Row,Col,LastLine,ValCon,Ext,Num,I,Prefix,SrchMask
  469. IF PCOUNT()<1
  470.   Mask='*.*'
  471. ENDIF
  472. IF TYPE('Mask')#'C'
  473.   Mask='*.*'
  474. ENDIF
  475. Selected=Mask
  476. SrchMask=''
  477. IF PCOUNT()<3
  478.   MustExist=.F.
  479. ENDIF
  480. IF TYPE('MustExist')#'L'
  481.   MustExist=.F.
  482. ENDIF
  483. IF MustExist
  484.   ValCon='Selected'
  485. ELSE
  486.   ValCon="''"
  487. ENDIF
  488. IF PCOUNT()<4
  489.   Title='Directory of '+alltrim(Mask)+' files.'
  490. ENDIF
  491. DO WHIL '*' $ Selected
  492.   Ext=''
  493.   Mask=Selected
  494.   IF ! '.*' $ Mask
  495.     Ext=RIGHT(Mask,len(Mask)-AT('.',Mask))
  496.   ENDIF
  497.   DECLARE FILES[ADIR(Mask)]
  498.   Num=0
  499.   DO SHOWFILES WITH Mask,Files,Num,Title
  500.   Insert=''
  501.   DO CASE
  502.   CASE '\' $ Mask
  503.     p=len(mask)-2
  504.     DO WHIL substr(mask,p,1)#'\'.AND.P>0
  505.       p=p-1
  506.     ENDDO
  507.     IF P>0
  508.       Insert=left(mask,p)
  509.     ENDIF
  510.   CASE ':' $ Mask
  511.     p=len(mask)-2
  512.     DO WHIL ( ! substr(mask,p,1) $ ':\').AND.P>0
  513.       p=p-1
  514.     ENDDO
  515.     IF P>0
  516.       Insert=left(mask,p)
  517.     ENDIF
  518.   ENDC
  519.   IF ! Empty(Selected)
  520.     I=ASRCH(Files,Selected)
  521.   ENDIF
  522.   IF DIV(Num,5)=1
  523.     LastLine=1
  524.   ELSE
  525.     LastLine=DIV(Num,5)+1
  526.   ENDIF
  527.   @ 24,0 SAY 'File '
  528.   SET COLO TO W+
  529.   Selected=Files[I]
  530.   key=0
  531.   DO WHIL key#13.AND.key#27.AND.Num>0
  532.     DO COL2
  533.     @ 24,5
  534.     @ 24,5 SAY Insert+trim(Files[I])+space(60-len(Insert+trim(files[i])))
  535.     SET COLO TO W+
  536.     @ 4+DIV(I-1,5),4+MOD(I-1,5)*14 SAY ''
  537.     key=inkey(0)
  538.     @ 4+DIV(I-1,5),4+MOD(I-1,5)*14 SAY ' '
  539.     DO CASE
  540.     Case Key=HelpKey
  541.       DO COL1
  542.       @ 0,0 SAY 'Move: arrows, [Home], [End]; [Enter] selects file, [Esc] to type in file'
  543.     CASE Key=LfArrow
  544.       i=IF(I>1,i-1,i)
  545.     CASE Key=RtArrow
  546.       i=IF(i<num,i+1,i)
  547.     CASE Key=HomeKey
  548.       i=1
  549.     CASE Key=EndKey
  550.       I=Num
  551.     CASE Key=UpArrow
  552.       i=IF(i-5>1,i-5,1)
  553.     CASE Key=DnArrow
  554.       i=if(I+5<Num,i+5,Num)
  555.     CASE Key=13
  556.       Selected=Files[I]
  557.     CASE Key>31.AND.Key<127
  558.       IF KEY#32
  559.         SrchMask=SrchMask+UPPER(CHR(key))
  560.         I=ASCAN(Files,SrchMask)
  561.         I=IF(I=0,ASRCH(Files,SrchMask),I)
  562.       ELSE
  563.         SrchMask=''
  564.       ENDIF
  565.     ENDC
  566.   ENDDO
  567.   IF num>0
  568.     Selected=Insert+trim(Files[I])+space(60-len(Insert+trim(files[i])))
  569.   ELSE
  570.     Selected=space(60)
  571.   ENDIF
  572.   DO COL1
  573.   @ 0,0
  574.   IF Key#13
  575.     @ 24,5
  576.     @ 24,5 GET Selected PICT '@K!' VALI FExists(&ValCon,Ext)
  577.     READ
  578.   ENDIF
  579. ENDDO
  580. RETU
  581.  
  582. PROCEDURE INDEX
  583. * Syntax:  DO INDEX
  584. * Notes.:  Revised code from Nantucket
  585. IF EMPTY(ALIAS())
  586.   DBFile=space(20)
  587.   DO SELEFILE WITH '*.DBF',DBFile,.T.,'Select a data file to index'
  588.   IF EMPTY(DBFILE)
  589.     RETU
  590.   ENDIF
  591.   USE &DBFile
  592. ENDIF
  593. NDXFile=space(20)
  594. DO SELEFILE WITH '*.NTX',NDXFile,.F.,'Select an index file name'
  595. IF EMPTY(NDXFile)
  596.   RETU
  597. ENDIF
  598. IF FILE(NDXFile)
  599.   USE &DBFile INDE &NDXFile
  600.   Key=INDEXKEY(0)
  601. ENDIF
  602. CLEA
  603. DO TITLE WITH 'Creating an index file'
  604. @ 12,0 SAY 'Key expression: ' GET Key
  605. READ
  606. INDEX ON &key TO &ntx
  607. ? RECCOUNT(), " Records indexed"
  608. RETU
  609.  
  610. PROCEDURE TITLE
  611. * Syntax.: DO TITLE WITH <Title>, [<starting line>]
  612. * Notes..: Clears line 1 and 2 and centers <Title> on line 1
  613. PARAMETER Ttl,start
  614. IF TYPE('Start')<>'N'
  615.   Start=1
  616. ENDIF
  617. @ Start,0
  618. @ Start+1,0
  619. BFrame = '┌ ┐│╛═╘│'
  620. Cent=INT(len(Ttl)/2)
  621. BotLine=INT(FCOUNT()/6+5)
  622. IF ISCOLOR()
  623.   SET COLOR TO RB/N
  624. ELSE
  625.   SET COLOR TO W/N
  626. ENDIF
  627. @ Start,40-cent-2,Start+1,40+cent+IF(LEN(Ttl)/2=INT(len(Ttl)/2),1,2) BOX Bframe
  628. SET COLO TO W+/N
  629. @ Start,40-cent-1 SAY ' '+Ttl+' '
  630. DO COL1
  631. RETURN
  632.  
  633. PROCEDURE OOPS
  634. * Syntax.: DO OOPS WITH <Message>
  635. * Notes..: Centers <Message> on line 24, and flashes it until a key is pressed
  636. PARAMETER Mess
  637. IF ISCOLOR()
  638.   SET COLOR TO R+*/N
  639. ELSE
  640.   SET COLOR TO W+*/N
  641. ENDIF
  642. @ 0,40-len(Mess)/2 SAY Mess
  643. key=inkey(0)
  644. DO COL1
  645. @ 0,40-len(mess)/2 say space(Len(Mess))
  646. RETURN
  647.  
  648. PROCEDURE PRINTOFF
  649. * Syntax.: DO PRINTOFF
  650. * Notes..: Assumes a public variable OUTPUT of type Character
  651. * Default: OUTPUT = 'S'creen
  652. IF TYPE('OUTPUT') # 'C'
  653.   OUTPUT='S'
  654. ENDIF
  655. IF OUTPUT='S'
  656.   WAIT
  657.   CLEA
  658. ENDIF
  659. SET ALTERNATE OFF
  660. SET PRINT OFF
  661. IF OUTPUT='D'
  662.   CLOSE ALTERNATE
  663. ENDIF
  664. OUTPUT='S'
  665. SET CONSOLE ON
  666. RETURN
  667.  
  668. PROCEDURE PRINTON
  669. * Syntax.: DO PRINTON
  670. * Notes..: Assumes a public variable OUTPUT as type 'C' for "S"creen, "P"rinter,
  671. *          or "D"isk
  672. * Default: OUTPUT = 'S'creen
  673. IF TYPE('OUTPUT') = 'U'
  674.   PUBLIC OUTPUT
  675.   OUTPUT='S'
  676. ENDIF
  677. IF TYPE('OUTPUT') # 'C'
  678.   OUTPUT='S'
  679. ENDIF
  680. SET PRINT OFF
  681. SET CONSOLE OFF
  682. SET ALTERNATE OFF
  683. DO CASE
  684. CASE UPPER(OUTPUT)='D'
  685.   SET ALTERNATE ON
  686. CASE UPPER(OUTPUT)='P'
  687.   IF ISPRINT()
  688.     SET PRINT ON
  689.   ELSE
  690.     ?? chr(7)
  691.     @ 0,0 SAY 'Hit any key when the printer is ready. [Esc] for Screen output.'
  692.     key=inkey(0)
  693.     DO WHILE Key#27 .AND. (! ISPRINT())
  694.       KEY=INKEY(0)
  695.     ENDDO
  696.     IF Key=27
  697.       SET CONS ON
  698.       OUTPUT='S'
  699.       Pause=.T.
  700.       @ 24,0 SAY 'Pause for each page (Y/N)? ' GET Pause
  701.       READ
  702.       @ 24,0
  703.     ENDIF
  704.     @ 0,0
  705.   ENDIF
  706. OTHE
  707.   SET CONSOLE ON
  708. ENDCASE
  709. RETURN
  710.  
  711. FUNCTION edfunc
  712. * Syntax:  Controlled by DBEDIT() in DBU.LIB
  713. * Notes.:  Powerful browsing function utility (more than dBASE has!)
  714. PARAMETERS mode,i
  715. PRIVATE cur_field,Key
  716. Key=LastKey()
  717.  
  718. * get the name of the current field into a regular variable
  719. cur_field = field_list[i]
  720.  
  721. * ?? 'before case'
  722. * inkey(0)
  723. DO CASE
  724.  
  725. CASE mode = 0
  726.   * idle mode..display record number
  727.   @ 0,0 SAY "Record " + STR(RECNO(),7)
  728.   RETURN(1)
  729. CASE mode = 1
  730.   DO OOPS WITH "Top of file."
  731.   inkey(1)
  732.   RETURN(1)
  733. CASE mode = 2
  734.   Cor=.N.
  735.   Key=Row()+1
  736.   @ Key,0 SAY 'Add another record (Y\N)? ' GET Cor
  737.   READ
  738.   @ Key,0
  739.   IF Cor
  740.     APPE BLAN
  741.   ENDIF
  742.   RETURN(1)
  743. CASE mode < 4
  744.   * case action can be implemented for each mode
  745.   RETURN(1)
  746. * mode 4..a keystroke not handled by DBEDIT
  747. CASE Key = 27 && Esc
  748.   * escape key..quit
  749.   RETURN(0)
  750. CASE Key = 21  &&CtrlU
  751.   IF DELETED()
  752.     RECA
  753.   ELSE
  754.     DELE
  755.   ENDIF
  756.   RETURN (2)
  757. CASE Key = 28 && Help Key
  758.   SAVE SCREEN TO EDFUNC1
  759.   DO BOXCOL
  760.   @  0,0 SAY '╔══════════════════╦═════════════════════╦══════════════╦════════════════════╗'
  761.   @  1,0 SAY '║ CURSOR   <-- --> ║         UP   DOWN   ║    DELETE    ║ Insert Mode:  Ins  ║'
  762.   @  2,0 SAY '║  Char:       '+chr(26)+'  ║ Record:           ║ Char:   Del  ║ Exit:        Esc   ║'
  763.   @  3,0 SAY '║  Field: Home End ║ Page:  PgUp  PgDn   ║ Field:  ^Y   ║ Abort:      Alt-C  ║'
  764.   @  4,0 SAY '║  Pan:  ^End ^Home║ File: ^PgUp ^PgDn   ║ Record: ^U   ║                    ║'
  765.   @  5,0 SAY '║  Pan:     ^ ^'+chr(26)+'  ║ Help:   F1          ║              ║ Set Options: ^Enter║'
  766.   @  6,0 SAY '╚══════════════════╩═════════════════════╩══════════════╩════════════════════╝'
  767.   DO BOXIT WITH 7,20,9,60,2
  768.   DO CNTR WITH '[Ctrl-──┘] for other options',8
  769.   key=inkey(0)
  770.   RESTORE SCREEN FROM EDFUNC1
  771.   IF key=10
  772.     DO OPTIONS
  773.     RETURN (2)
  774.   ELSE
  775.     RETURN (1)
  776.   ENDIF
  777. CASE Key = 10 && Ctrl-Enter
  778.   DO OPTIONS
  779.   RETURN (2)
  780. CASE (Key >31 .AND. Key<127) .OR. Key=13 && Valid ASCII Character
  781.   @ ROW(), COL() GET &cur_field
  782.   IF Key#13
  783.     KEYBOARD chr(Key)
  784.   ENDIF
  785.   READ
  786.   KEYBOARD chr(4) &&Right Arrow
  787.   RETURN (2)
  788. OTHE
  789.   RETURN (1)
  790. ENDCASE
  791. RETURN (1)
  792.  
  793. PROCEDURE OPTIONS
  794. * Syntax: DO OPTIONS
  795. * Notes.: List of options and executions for browsing.  Called from EDFUNC()
  796. PRIV I,Key
  797. SAVE SCREEN TO OPT1
  798. DO BOXIT WITH 0,0,6,79,2
  799. DO CNTR WITH '[F1] - Reset index order       [F2] - seek with active index ',1
  800. DO CNTR WITH '[F3] - DELETE FOR condition    [F4] - DELETE WHILE condition ',2
  801. DO CNTR WITH '[F5] - RECALL FOR condition    [F6] - RECALL WHILE condition ',3
  802. DO CNTR WITH '[F7] - REPLACE FOR condition   [F8] - REPLACE WHILE condition',4
  803. DO CNTR WITH '[F9] - LOCATE FOR condition   [F10] - CONTINUE LOCATE        ',5
  804. Key=inkey(0)
  805. IF TYPE('Cond') = 'U'
  806.   PUBL Cond
  807.   Cond=space(140)
  808. ENDIF
  809. IF TYPE('Cond') # 'C'
  810.   Cond=space(140)
  811. ENDIF
  812. @ 0,0 SAY CLS()
  813. DO CASE
  814. CASE Key = 28 &&F1
  815.   DO RESETINDEX
  816. CASE Key = -1 &&F2
  817.   DO GENSEEK
  818. CASE Key = -2 &&F3
  819.   DO SHOWFIELDS
  820.   DO TITLE WITH 'Enter the DELETING FOR condition'
  821.   @ 23,0 SAY 'Filter ' GET Cond
  822.   READ
  823.   IF ! Empty(Cond)
  824.     DELE FOR &Cond
  825.   ENDIF
  826. CASE Key = -3 &&F4
  827.   DO SHOWFIELDS
  828.   DO TITLE WITH 'Enter the DELETING WHILE condition'
  829.   @ 23,0 SAY 'Filter ' GET Cond
  830.   READ
  831.   IF ! Empty(Cond)
  832.     DELE WHIL &Cond
  833.   ENDIF
  834. CASE Key = -4 &&F5
  835.   DO SHOWFIELDS
  836.   DO TITLE WITH 'Enter the RECALLING FOR condition'
  837.   @ 23,0 SAY 'Condition' GET Cond
  838.   READ
  839.   IF ! Empty(Cond)
  840.     RECA FOR &Cond
  841.   ENDIF
  842. CASE Key = -5 &&F6
  843.   DO SHOWFIELDS
  844.   DO TITLE WITH 'Enter the RECALLING WHILE condition'
  845.   @ 23,0 SAY 'Condition' GET Cond
  846.   READ
  847.   IF ! Empty(Cond)
  848.     RECA WHIL &Cond
  849.   ENDIF
  850. CASE Key = -6 && F7
  851.   DO SHOWFIELDS
  852.   DO TITLE WITH 'Enter the REPLACING FOR condition'
  853.   FN=space(11)
  854.   Exp=SPACE(120)
  855.   @ 22, 0 SAY 'REPL ' GET FN PICT '@!' VALI TYPE(FN)#'U' .OR. EMPTY(FN)
  856.   @ 22,20 SAY 'WITH ' GET Exp PICT '@S59'
  857.   @ 23, 0 SAY 'FOR  ' GET Cond
  858.   READ
  859.   IF ! (EMPTY(FN).OR.EMPTY(Exp).OR.EMPTY(Cond))
  860.     REPL &FN WITH &Exp FOR &Cond
  861.   ENDIF
  862. CASE Key = -7 && F8
  863.   DO SHOWFIELDS
  864.   DO TITLE WITH 'Enter the REPLACING WHILE condition'
  865.   FN=space(11)
  866.   Exp=SPACE(60)
  867.   @ 22, 0 SAY 'REPL  ' GET FN PICT '@!' VALI TYPE(FN)#'U' .OR. EMPTY(FN)
  868.   @ 22,20 SAY 'WITH  ' GET Exp PICT '@S59'
  869.   @ 23, 0 SAY 'WHILE ' GET Cond
  870.   READ
  871.   IF ! (EMPTY(FN).OR.EMPTY(Exp).OR.EMPTY(Cond))
  872.     DO WHIL &Cond
  873.       Currec=recno()
  874.       SKIP
  875.       nextrec=recno()
  876.       SKIP -1
  877.       REPL &FN WITH &Exp
  878.       GOTO Nextrec
  879.     ENDDO
  880.   ENDIF
  881. CASE Key = -8 &&F9
  882.   DO SHOWFIELDS
  883.   DO TITLE WITH 'Enter the LOCATING FOR condition'
  884.   @ 23,0 SAY 'Condition' GET Cond
  885.   READ
  886.   IF ! Empty(Cond)
  887.     LOCA FOR &Cond
  888.   ENDIF
  889. CASE Key = -9 &&F10
  890.   CONTINUE
  891. ENDC
  892. REST SCREEN FROM OPT1
  893. RETU
  894.  
  895. PROCEDURE RESETINDEX
  896. * Syntax: DO RESETINDEX
  897. * Notes.: Allows you to change the master index on any active index files
  898. PRIV I
  899. SAVE SCREEN TO RES1
  900. @ 0,0 SAY CLS()
  901. DO TITLE WITH 'Resetting index order'
  902. @ 4,0 SAY 'Current index: '+IndexKey(0)
  903. Key=1
  904. I = 1
  905. DO WHIL ! Empty(IndexKey(Key))
  906.   ? 'Index',str(Key,2),':',IndexKey(Key)
  907.   I= IIF (IndexKey(0)=IndexKey(key),key,i)
  908.   key=key+1
  909. ENDDO
  910. IF ! Empty(IndexKey(0))
  911.   @ 24,0 SAY 'Select index number: ' GET I PICT '9' RANG 0,Key
  912.   READ
  913.   SET ORDER TO I
  914. ENDIF
  915. REST SCREEN FROM RES1
  916. RETU
  917.  
  918. PROCEDURE GENSEEK
  919. * Syntax:  DO GENSEEK
  920. * Notes.:  Allows you to do a seek on the active index.  Dynamically
  921. *          determines the picture clause to use depending on the index
  922. *          expression.
  923. PRIV INK,PC
  924. SAVE SCREEN TO GENSEEK1
  925. @ 0,0 SAY CLS()
  926. DO TITLE WITH 'Seeking with active index on data file '+Alias()
  927. IF ! EMPTY(INDEXKEY(0))
  928.   INK=INDEXKEY(0)
  929.   INK=&INK
  930. ENDIF
  931. DO CASE
  932. CASE EMPTY(INDEXKEY(0))
  933.   @ 4,0 SAY 'No index active.'
  934.   Key=0
  935.   @ 24,0 SAY 'Record number to go to ' GET Key PICT '9999999' RANG 0,RecCount()
  936.   READ
  937.   IF ! Empty(Key)
  938.     GOTO Key
  939.   ENDIF
  940. CASE TYPE('INK')='N'
  941.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  942.   INK=str(INK)
  943.   IF AT('.',INK)>0
  944.     PC=REPL('9',AT('.',INK)-1)+'.'+REPL('9',LEN(INK)-AT('.',INK))
  945.   ELSE
  946.     PC=REPL('9',LEN(INK))
  947.   ENDIF
  948.   INK = 0
  949.   @ 24,0 SAY 'Seek ' GET INK PICT '&PC'
  950.   READ
  951.   SEEK INK
  952. CASE TYPE('INK')='C'
  953.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  954.   PC=REPL('X',LEN(INK))
  955.   @ 24,0 SAY 'Seek ' GET INK PICT '&PC'
  956.   READ
  957.   SEEK trim(INK)
  958. CASE TYPE('INK')='D'
  959.   @ 4,0 SAY 'Index key: '+INDEXKEY(0)
  960.   @ 24,0 SAY 'Seek ' GET INK PICT '@D'
  961.   READ
  962.   SEEK INK
  963. ENDC
  964. RESTORE SCREEN FROM GENSEEK1
  965. RETU
  966.  
  967. PROCEDURE FORMFEED
  968. * Syntax:  DO FORMFEED
  969. * Notes.:  Assumes a public variable OUTPUT declared as character
  970. DO CASE
  971. CASE OUTPUT='S'
  972.   IF PAUSE
  973.     DO CNTR WITH 'Hit a key'
  974.     inkey(0)
  975.   ENDIF
  976.   CLEA
  977. CASE OUTPUT = 'D'
  978.   ?? chr(12)
  979. CASE OUTPUT = 'P'
  980.   EJEC
  981. ENDC
  982. RETU
  983.  
  984. FUNCTION ULEN
  985. * Syntax: ULEN ( <ExpC> )
  986. * Return: The length of any variable (variable name is passed as character),
  987. *         0 if undefined variable
  988. PARA var
  989. IF PCOUNT()<1
  990.   RETURN ( 0 )
  991. ENDIF
  992. RETURN len(CSTRING(Var))
  993.  
  994. PROCEDURE CNTR
  995. * Syntax:  DO CNTR WITH <Text>, [<Line>]
  996. * Notes.:  Centers <Text> on <Line>.  <Line> defaults to 0
  997. *
  998. PARA Text,Line
  999. IF Pcount()<2
  1000.   Line=0
  1001. ENDIF
  1002. @ Line,40-len(text)/2 SAY text
  1003. RETU
  1004.  
  1005. PROCEDURE CORRECT
  1006. * Syntax:  DO CORRECT
  1007. * Notes.:  Assumes a public variable COR.  Changes COR to .F. if the current
  1008. *          GET variables have been updated, then prompts for correctness.
  1009. Cor=IF(UPDATED(),.N.,.T.)
  1010. @ 24,0
  1011. @ 24,0 SAY 'Is everything correct (Y\N) ? ' GET Cor
  1012. READ
  1013. @ 24,0
  1014. RETU
  1015.  
  1016. PROCEDURE SHOWCLIP
  1017. * Syntax:  DO SHOWCLIP
  1018. * Notes.:  Shows the status of the Clipper environment.  Uses Tom Rettig's
  1019. *          Library.
  1020. ?  'ALTERNATE: ',UNTRIM(STATUS('ALTERNATE'),3)
  1021. ?? ' BELL:      ',UNTRIM(STATUS('BELL'),3)
  1022. ?? ' CONFIRM:   ',UNTRIM(STATUS('CONFIRM'),3)
  1023. ?? ' CONSOLE:   ',UNTRIM(STATUS('CONSOLE'),3)
  1024. ?? ' DECIMAL:   ',STR(STATUS('DECIMAL'),3)
  1025. ?  'DEFAULT:   ',UNTRIM(STATUS('DEFAULT'),3)
  1026. ??  ' DELETED:   ',UNTRIM(STATUS('DELETED'),3)
  1027. ??  ' DELIMSTAT: ',UNTRIM(STATUS('DELIMSTAT'),3)
  1028. ??  ' DELIMCHRS: ',UNTRIM(STATUS('DELIMCHRS'),3)
  1029. ??  ' DEVICE: ',STATUS('DEVICE')
  1030. ?  'ESCAPE:    ',UNTRIM(STATUS('ESCAPE'),3)
  1031. ??  ' EXACT:     ',UNTRIM(STATUS('EXACT'),3)
  1032. ??  ' FIXED:     ',UNTRIM(STATUS('FIXED'),3)
  1033. ??  ' INTENSITY: ',UNTRIM(STATUS('INTENSITY'),3)
  1034. ??  ' MARGIN:    ',STR(STATUS('MARGIN'),3)
  1035. ?  'PATH:      ',UNTRIM(STATUS('PATH'),3)
  1036. ??  ' PRINT:     ',UNTRIM(STATUS('PRINT'),3)
  1037. RETURN
  1038.  
  1039. PROCEDURE STATS
  1040. * Syntax:  DO STATS
  1041. * Notes.:  Closest emulation of dBASE's DISPLAY STATUS I could think of
  1042. PRIV Ret_Area,Cur_AREA,i,J,K
  1043. SAVE SCREEN TO STAT1
  1044. IF Empty(Alias())
  1045.   @ 24,0 SAY 'No files in use.'
  1046.   inkey(0)
  1047. ENDIF
  1048. @ 0,0 CLEA
  1049. Ret_Area=ALIAS()
  1050. ? 'Current work area:  ',Ret_Area
  1051. ? 'Current index key:  ',IndexKey(0)
  1052. K=0
  1053. FOR I=1 to 10
  1054.   IF ! EMPTY(Alias(I))
  1055.     K=K+1
  1056.     IF K>3
  1057.       K=0
  1058.       inkey(0)
  1059.     ENDIF
  1060.     Cur_Area=Alias(I)
  1061.     SELE &Cur_Area
  1062.     ? 'Work area',str(i,2),'database:',Alias(I)
  1063.     ? 'Number of records:',reccount()
  1064.     ? 'Current record:   ',recno()
  1065.     ? 'Master index key: ',INDEXKEY(0)
  1066.     FOR J=1 to 7
  1067.       IF ! Empty(Index(J))
  1068.         ? 'Index',str(j,1),'key:',INDEXKEY(J)
  1069.       ENDIF
  1070.     NEXT
  1071.     ?
  1072.   ENDIF
  1073. NEXT
  1074. inkey(0)
  1075. SELE &Ret_Area
  1076. @ 0,0 CLEA
  1077. DO SHOWSYS
  1078. inkey(0)
  1079. DO SHOWCLIP
  1080. inkey(0)
  1081. i='I'
  1082. DO WHIL ! EMPTY(I)
  1083.   ACCEPT 'Expression to evaluate: ' TO I
  1084.   IF ! EMPTY(I)
  1085.     ? i,':',&i
  1086.   ENDIF
  1087. ENDDO
  1088. RESTORE SCREEN FROM STAT1
  1089. RETU
  1090.  
  1091. PROCEDURE PACKEM
  1092. * Syntax:  DO PACKEM
  1093. * Notes.:  Will use DELCOUNT() to count the deleted records in the file if
  1094. *          RecCount()<1000, otherwise prompts for it.  Prompts for Packing.
  1095. PRIV BP
  1096. DO COL1
  1097. IF EMPTY(Alias())
  1098.   DO CNTR WITH 'No file in use',0
  1099.   inkey(0)
  1100.   @ 0,0
  1101. ENDIF
  1102. CLEA
  1103. DO TITLE WITH 'Packing the '+Alias()+' datafile'
  1104. DO BOXIT WITH 4,10,8,70
  1105. BP=RecCount()
  1106. Cor=.Y.
  1107. IF BP>1000
  1108.   @ 24,0 SAY ltrim(str(BP))+' records. Count deleted ones (Y/N)? ' GET Cor
  1109.   READ
  1110.   @ 24,0
  1111. ENDIF
  1112. IF Cor
  1113.   @ 5,22 SAY 'Records to remove:  '
  1114.   K=DelCount()
  1115.   ?? ltrim(str(K))
  1116. ELSE
  1117.   K=1
  1118. ENDIF
  1119. DO CNTR WITH 'Packing '+Alias()+' will remove all deleted records.',7
  1120. IF K>0
  1121.   Cor=.Y.
  1122.   @ 6,22 SAY 'Go ahead and pack (Y/N)? ' GET Cor
  1123.   READ
  1124.   IF Cor
  1125.     PACK
  1126.     DO OOPS WITH ltrim(str(BP-RecCount()))+' records removed.'
  1127.   ENDIF
  1128. ELSE
  1129.   inkey(0)
  1130. ENDIF
  1131. RETU
  1132.  
  1133. PROCEDURE SETFILT
  1134. * Syntax:  DO SETFILT
  1135. * Notes.:  Allows you to set a filter with limited help. Assumes public
  1136. *          FiltCond
  1137. IF EMPTY(Alias())
  1138.   DO CNTR WITH 'No file selected',24
  1139.   inkey(0)
  1140.   RETU
  1141. ENDIF
  1142. IF TYPE('FiltCond')='C'
  1143.   @ 12,0 SAY 'Current filter: '+FiltCond
  1144.   Cor=.Y.
  1145.   @ 24,0 SAY 'Use current filter (Y\N)? ' GET Cor
  1146.   READ
  1147.   IF Cor
  1148.     RETU
  1149.   ENDIF
  1150. ELSE
  1151.   FiltCond=space(140)
  1152. ENDIF
  1153. Ans=1
  1154. DECL FI[1]
  1155. FI[1]=space(11)
  1156. DO COL1
  1157. CLEA
  1158. DO WHIL ANS#0
  1159.   @ 1, 0 PROMPT 'Edit'  MESSAGE 'Edit the filter'
  1160.   @ 1,10 PROMPT 'Field' MESSAGE 'Select a field'
  1161.   @ 1,20 PROMPT 'Help'  MESSAGE 'Get help in creating filter'
  1162.   @ 1,30 PROMPT 'Quit'  MESSAGE 'Filter is finished'
  1163.   MENU TO ANS
  1164.   DO CASE
  1165.   CASE Ans = 1
  1166.     @ 22,0 SAY CLS()
  1167.     @ 22,0 SAY 'Filter: ' GET FiltCond
  1168.     READ
  1169.   CASE Ans = 2
  1170.     SAVE SCREEN TO FILT1
  1171.     DO SELEFIELDS WITH FI,FCount()
  1172.     RESTORE SCREEN FROM FILT1
  1173.     FiltCond=untrim(trim(FiltCond)+FI[1],140)
  1174.     @ 22,0 SAY CLS()
  1175.     @ 22,0 SAY 'Filter: '
  1176.     DO COL2
  1177.     ?? FiltCond
  1178.     DO COL1
  1179.     KEYBOARD 'E'+chr(6) && end key
  1180.   CASE Ans = 3
  1181.     SAVE SCREEN TO FILT1
  1182.     @ 0,0 CLEA
  1183.     DO BOXIT WITH 0,0,15,79
  1184.     DO CNTR WITH 'Conditions                       Common functions                ',1
  1185.     DO CNTR WITH '!     negates                    str(pi,4,2)       = "3.14", etc.',2
  1186.     DO CNTR WITH '.NOT. negates                    dtoc(Christmas)   = "12/25/87"  ',3
  1187.     DO CNTR WITH '.AND.                            dtos(Christmas)   = "19871225"  ',4
  1188.     DO CNTR WITH '.OR.                             ctod("12/25/87")  = Christmas   ',5
  1189.     DO CNTR WITH '()    nest conditions            upper("John")     = "JOHN"      ',6
  1190.     DO CNTR WITH '$     text string contained in   left("12345",2)   = "12"        ',7
  1191.     DO CNTR WITH '#     not equal to               right("12345",2)  = "45"        ',8
  1192.     DO CNTR WITH '<,>,= same meanings              substr("123",2,1) = "2"         ',9
  1193.     DO CNTR WITH 'Examples',11
  1194.     DO CNTR WITH '"JOHN" $ UPPER(First)              means "is JOHN in First"      ',12
  1195.     DO CNTR WITH 'Datefield > CTOD("12/25/87")       means "Datefield > Christmas" ',13
  1196.     DO CNTR WITH '(N1 > N2) .AND. (N4 = N3)                                        ',14
  1197.     inkey(0)
  1198.     RESTORE Screen FROM FILT1
  1199.     KEYBOARD 'E'+chr(6) && end key
  1200.   CASE Ans = 4
  1201.     Ans = 0
  1202.   ENDC
  1203. ENDDO
  1204. IF ! EMPTY(FiltCond)
  1205.   SET FILT TO &FiltCond
  1206. ENDIF
  1207. RETU
  1208.  
  1209. PROCEDURE OPCHOICE
  1210. * Syntax:  DO OPCHOICE
  1211. * Notes.:  Determines where output is going: Disk, Printer, or Screen
  1212. *          Assumes a public character variable called OUTPUT for other
  1213. *          procedures such as PrintOn, PrintOff, and FormFeed
  1214. PRIVATE ANSWER
  1215. ANSWER=0
  1216. @ 23,0 CLEA
  1217. @ 23,0  PROMPT 'Printer' MESSAGE 'Select output to the printer'
  1218. @ 23,10 PROMPT 'Screen' MESSAGE 'Select output to the screen'
  1219. @ 23,20 PROMPT 'Disk' MESSAGE 'Select output to a disk file'
  1220. @ 23,30 PROMPT 'Quit' MESSAGE "Don't select an output device and quit"
  1221. MENU TO ANSWER
  1222. @ 23,0 CLEA
  1223. DO CASE
  1224. CASE ANSWER=1
  1225.   OUTPUT='P'
  1226. CASE ANSWER=2
  1227.   OUTPUT='S'
  1228.   Pause=.F.
  1229.   @ 23,0 SAY 'Pause for each page (Y/N)? ' GET Pause
  1230.   READ
  1231. CASE ANSWER=3
  1232.   OUTPUT='D'
  1233.   * sets up the ALTERNATE file to a disk file name after verifying
  1234.   * an overwrite if the file exists
  1235.   Cor=.N.
  1236.   File=space(20)
  1237.   DO SELEFILE WITH '*.TXT',File,.N.,'Select a file for output. "*" in filename for a new directory'
  1238.   IF ! EMPTY(File)
  1239.     SET ALTE TO &File
  1240.   ELSE
  1241.     OUTPUT='S'
  1242.   ENDIF
  1243. ENDC
  1244. RETU
  1245.  
  1246. FUNC ZERO
  1247. * Syntax:  Zero( <ExpN1>, <ExpN2> )
  1248. * Notes.:  Returns <ExpN1>/<ExpN2> if <ExpN2>#0, otherwise 0
  1249. PARA ZN1,ZN2
  1250. IF PCOUNT()<2
  1251.   RETURN (0)
  1252. ENDIF
  1253. IF ZN2=0
  1254.   RETURN (0)
  1255. ENDIF
  1256. RETURN ( ZN1/ZN2)
  1257.  
  1258. FUNC SZERO
  1259. * Syntax:  Sero( <ExpN1>, <ExpN2> )
  1260. * Notes.:  Returns string of Zero(<ExpN1>,<ExpN2>)
  1261. PARA ZN1,ZN2
  1262. IF PCOUNT()<2
  1263.   RETURN ('')
  1264. ENDIF
  1265. RETURN ( ZERO(ZN1,ZN2) )
  1266.  
  1267. PROCEDURE INITVARS
  1268. * Syntax:  DO INITVARS
  1269. * Notes.:  Copies the data from the current record to memory variables of the same
  1270. *          name
  1271. PRIV I,FN
  1272. FOR I=1 TO FCOUNT()
  1273.   FN=Field(I)
  1274.   IF TYPE('X&FN')='U'
  1275.     PUBL X&FN
  1276.   ENDIF
  1277.   X&FN = &FN
  1278. NEXT
  1279.  
  1280. PROCEDURE REPLVARS
  1281. * Syntax:  DO REPLVARS
  1282. * Notes.:  Copies the data from the memory variables to the field in the
  1283. *          current record of the same name
  1284. PRIV I,FN
  1285. FOR I=1 TO FCOUNT()
  1286.   FN=Field(I)
  1287.   IF TYPE('X&FN')#'U'
  1288.     REPL &FN WITH X&FN
  1289.   ENDIF
  1290. NEXT
  1291. RETU
  1292.  
  1293. PROCEDURE COPYVARS
  1294. * Syntax:  DO COPYVARS
  1295. * Notes.:  Copies the data from the current record to a new record
  1296. PRIV I,FN
  1297. FOR I=1 TO FCOUNT()
  1298.   FN=Field(I)
  1299.   X&FN = &FN
  1300. NEXT
  1301. APPE BLAN
  1302. FOR I=1 TO FCOUNT()
  1303.   FN=Field(I)
  1304.   REPL &FN WITH X&FN
  1305. NEXT
  1306. RETU
  1307.  
  1308. PROC BOXCOL
  1309. * Syntax:  DO BOXCOL
  1310. * Notes.:  Sets the box color for color or monochrome systems
  1311. IF ISCOLOR()
  1312.   SET COLO TO GR/N
  1313. ELSE
  1314.   SET COLO TO W/N
  1315. ENDIF
  1316. RETU
  1317.  
  1318. PROC COL1
  1319. * Syntax:  DO COL1
  1320. * Notes.:  Sets the normal screen for color or monochrome systems
  1321. IF ISCOLOR()
  1322.   SET COLO TO GR+/N,W+/B,,,W/B
  1323. ELSE
  1324.   SET COLO TO W+/N,N/W,,,B/N
  1325. ENDIF
  1326. RETU
  1327.  
  1328. PROC COL2
  1329. * Syntax:  DO COL2
  1330. * Notes.:  Sets the inverse (GET field) screen for color or monochrome systems
  1331. IF ISCOLOR()
  1332.   SET COLO TO W/B
  1333. ELSE
  1334.   SET COLO TO B/N
  1335. ENDIF
  1336. RETU
  1337.  
  1338. FUNC FRAME
  1339. * Syntax.:  Frame ( <ExpC> )
  1340. * Returns:  A Frame Border type
  1341. PARA Border
  1342. PRIV BFrame
  1343. IF PCOUNT()<1
  1344.   Border=1
  1345. ENDIF
  1346. DO CASE
  1347. CASE Border=0
  1348.   Bframe = "        "
  1349. CASE Border=2
  1350.   BFrame = "╔═╗║╝═╚║"
  1351. CASE Border=3
  1352.   BFrame = "╒═╕│╛═╘│"
  1353. CASE Border=4
  1354.   BFrame = "╓─╖║╜─╙║"
  1355. CASE Border=5
  1356.   BFrame = "▄▄▄█▀▀▀█"
  1357. CASE Border=6
  1358.   BFrame = "▄▄▄▐▀▀▀▌"
  1359. CASE Border=7
  1360.   BFrame = "████████"
  1361. CASE Border=8
  1362.   BFrame = "▓▓▓▓▓▓▓▓"
  1363. CASE Border=9
  1364.   BFrame = "▒▒▒▒▒▒▒▒"
  1365. CASE Border=10
  1366.   BFrame = "░░░░░░░░"
  1367. CASE Border=11
  1368.   BFrame = "┌ ┐│╛═╘│"
  1369. OTHE
  1370.   Bframe = "┌─┐│┘─└│"
  1371. ENDC
  1372. RETURN BFrame
  1373.  
  1374. PROC BOXIT
  1375. * Syntax.: DO BOXIT WITH <Top>, <Left>, <Bottom>, <Right>,[<Border>,[<Clear>]]
  1376. * Notes..: Creates a box at the above locations with <Border>
  1377. PARAMETERS Top,Left,Bottom,Right,Border,Clear
  1378. IF TYPE("Border")#"N"
  1379.   Border=1
  1380. ENDIF
  1381. IF TYPE("Right")#"N".OR.TYPE("Left")#"N".OR.TYPE("Top")#"N".OR.TYPE("Bottom")#"N"
  1382.   RETURN
  1383. ENDIF
  1384. IF TYPE("Clear")#"C"
  1385.   Clear=''
  1386. ENDIF
  1387. DO BOXCOL
  1388. @ Top,left CLEA TO Bottom,Right
  1389. IF Border#0
  1390.   @ Top,left,bottom,right BOX Frame(Border)+Clear
  1391. ENDIF
  1392. DO COL1
  1393. RETU
  1394. * EOP: Procedure BOXIT
  1395.  
  1396. FUNCTION DEFAULT
  1397. * Syntax:  Default( <Variable to initialize>, <Value> )
  1398. * Notes.:  Initializes a variable with the value passed with it.  If the
  1399. *          type of the variable is in conflict with the value, the variable
  1400. *          will be initialized to the value
  1401. PARA IV,PV
  1402. IF PCOUNT()<2
  1403.   RETURN ( .F. )
  1404. ENDIF
  1405. IF TYPE('IV')='U'
  1406.   RETURN ( PV )
  1407. ENDIF
  1408. IF TYPE('IV')#TYPE('PV')
  1409.   RETURN ( PV )
  1410. ENDIF
  1411. RETURN (IV)
  1412.  
  1413. PROC ALIST
  1414. * Syntax:  DO ALIST WITH <AR>
  1415. * Notes.:  Lists the array <AR> to the output device
  1416. *
  1417. PARA AR
  1418. PRIV TotElem
  1419. IF PCOUNT()<1
  1420.   RETURN
  1421. ENDIF
  1422. IF TYPE('AR')#'A'
  1423.   RETURN
  1424. ENDIF
  1425. TotElem=Len(AR)
  1426. FOR I = 1 to TotElem
  1427.   ? I,AR[I]
  1428. NEXT
  1429. RETURN
  1430.  
  1431. PROC ASORT
  1432. * Syntax:  DO Asort WITH <Array> [,<Order>]
  1433. * Notes.:  Returns sorted array if all elements in the array are the same type.
  1434. *          I attempted doing this as a function, but evidently the pointers got
  1435. *          as confused as I did, and it would not RETURN the array correctly.
  1436. PARA AR,Order
  1437. PRIV CurEl,MovEl,I,Expression,TotElem
  1438. Expression='AR[I]<AR[CurEl]' && This expression is used to evaluate an
  1439.                              *  ascending or descending sort
  1440. DO CASE
  1441. CASE PCOUNT()<1
  1442.   RETURN &&( '' )
  1443. CASE TYPE('AR')#'A'
  1444.   RETURN &&( AR )
  1445. CASE Pcount()=2
  1446.   IF Type('Order')='C'
  1447.     * Assigning sorting order
  1448.     Expression=IF(UPPER(Order)='D','AR[CurEl]<AR[I]','AR[I]<AR[CurEl]')
  1449.   ENDIF
  1450. ENDC
  1451. TotElem=LEN(AR)
  1452. FOR CurEl = 2 TO TotElem
  1453.   i=1
  1454.   DO WHIL &Expression     && You don't need the out-of-dimension test because
  1455.     i=i+1                 && the last element will be equal to itself.  There
  1456.   ENDDO                   && is no way to go beyond TotElem.
  1457.   IF CurEl#I              && Have to move element
  1458.     MovEl=AR[CurEl]       && Assigning element to temp variable
  1459.     ADel(AR,CurEl)        && Removing it from where it was in the array
  1460.     AIns(AR,I)            && Making a blank space for it
  1461.     AR[i]=MovEl           && Putting the element back in
  1462.   ENDIF
  1463. NEXT
  1464. RETURN &&( AR )
  1465.  
  1466. FUNC ASRCH
  1467. * Syntax:  Asrch( <Array>,<Targ> )
  1468. * Notes.:  Returns the number in the array closest to the target
  1469. *          Assumes the array is sorted in Ascending or Descending order
  1470. PARA AR,Targ
  1471. PRIV I,TotElem,Hi,Lo,Direction,Mid
  1472. IF PCOUNT()<2
  1473.   RETURN ( 0 )
  1474. ENDIF
  1475. IF TYPE('AR')#'A'
  1476.   RETURN ( 0 )
  1477. ENDIF
  1478. TotElem=Len(AR)
  1479. IF TotElem<2
  1480.   RETURN ( 1 )
  1481. ENDIF
  1482. Mid=INT(TotElem/2)
  1483. Hi=TotElem
  1484. Lo=1
  1485. DO WHIL HI-LO>1
  1486.   DO CASE
  1487.   CASE AR[Mid]=Targ
  1488.     Hi=Mid
  1489.     Lo=Mid
  1490.   CASE AR[Mid]<Targ
  1491.     Lo=Mid
  1492.     Mid=INT((Hi+Lo)/2)
  1493.   OTHE
  1494.     Hi=Mid
  1495.     Mid=INT((Hi+Lo)/2)
  1496.   ENDC
  1497. ENDDO
  1498. RETURN ( Mid )
  1499.  
  1500. PROCEDURE SHOWSYS
  1501. * Syntax:  DO ShowSys
  1502. * Notes.:  Shows DOS and System configurations
  1503. ? 'Operating system:       DOS',OS()
  1504. ? 'Free memory:           ',alltrim(str(Mem())),'Bytes'
  1505. ? 'Current directory:     ',Curdir(CurDrive())
  1506. ? 'Disk type:             ',IF(ISFIXED(CurDrive()),'Hard','Floppy')
  1507. ? 'Current date:          ',CDOW(Date())+',',DTOW(Date())
  1508. ? 'Current time:          ',AMPM(Time())
  1509. ? 'Display type:          ',IF(IsColor(),'Color','Monochrome')
  1510. ? 'Configured Buffers:    ',alltrim(str(Buffers(),3,0))
  1511. ? 'Configured Files:      ',alltrim(str(Files(),3,0))
  1512. ? 'Configured Last drive: ',LastDrive()
  1513. RETU
  1514.  
  1515. PROCEDURE INSTALL
  1516. * Syntax.:  DO INSTALL [ WITH <Configuration file> ]
  1517. * Notes..:  Allows the user to install their system
  1518. PARA CONFIG
  1519. IF TYPE('WorkDir')='U'
  1520.   PUBL WorkDir,SysDir,SrchPath,BackDir
  1521. ENDIF
  1522. IF Type('OUTPUT')='U'
  1523.   PUBL Output,Cor
  1524.   Output='S'
  1525.   Cor=.F.
  1526. ENDI
  1527. IF Pcount()=0
  1528.   Config='CLINST.MEM'
  1529. ENDIF
  1530. DO COL1
  1531. IF File(Config)
  1532.   RESTORE FROM &Config ADDI
  1533. ENDIF
  1534. WorkDir=DEFAULT(WorkDir,untrim(curr_dir(),60))
  1535. SysDir=DEFAULT(SysDir,untrim(curr_dir(),60))
  1536. SrchPath=DEFAULT(SrchPath,untrim(GETE('PATH'),122))
  1537. BackDir=DEFAULT(BackDir,untrim('B:\',40))
  1538. OutPut=DEFAULT(OutPut,'S')
  1539. CLEA
  1540. DO TITLE WITH 'Setting up &Config configuration file'
  1541. @ 10,0 SAY 'Miscellaneous information'
  1542. DO SHOWSYS
  1543. Cor=.F.
  1544. DO WHIL ! Cor
  1545.   @ 4,0 SAY 'Default directory ' GET WorkDir  PICT '@!' VALI ValDir(WorkDir)
  1546.   @ 5,0 SAY 'System directory  ' GET SysDir   PICT '@!' VALI ValDir(SysDir)
  1547.   @ 6,0 SAY 'File search path  ' GET SrchPath PICT '@!S60'
  1548.   @ 8,0 SAY 'Default output : [S]creen or [P]rinter ' GET OutPut PICT '!' VALI Output $ [SP]
  1549.   READ
  1550.   Cor= (! Updated())
  1551.   @ 24,0 Say 'Is everything correct (Y\N)? ' GET Cor
  1552.   READ
  1553.   @ 24,0
  1554. ENDDO
  1555. SAVE TO &Config
  1556. SET PATH TO &Path
  1557. IF Curr_Dir()#trim(WorkDir)
  1558.   chdir(trim(WorkDir))
  1559. ENDIF
  1560. DO OOPS WITH 'Installation completed'
  1561. RETU
  1562.  
  1563. FUNC OS
  1564. * Syntax.: OS()
  1565. * Notes..: Uses Tom Rettig's Library
  1566. * Returns: DOS Version Number
  1567. RETURN DosVers()
  1568.  
  1569. FUNC ValDir
  1570. * Syntax.:  ValDir( <Directory> )
  1571. * Returns:  .T. if <Directory> is valid, .F. otherwise
  1572. PARA Direc
  1573. @ 0,0
  1574. IF IsDir(Direc)
  1575.   RETURN (.T.)
  1576. ENDIF
  1577. DO CNTR WITH Trim(Direc)+' was not found.'
  1578. inkey(0)
  1579. RETURN (.F.)
  1580.  
  1581. FUNCTION ISFOUND
  1582. * Syntax:  IsFound ( <Mask> [,<File>] )
  1583. * Notes.:  SEEKS <Mask> in the current file, or else selects <File> and SEEKS
  1584. *          <Mask>, re-selecting the current file before returning
  1585. *
  1586. PARA Mask,File
  1587. PRIV RetArea,OK
  1588. OK=PCOUNT()
  1589. IF OK<1
  1590.   RETURN ( .F. )
  1591. ENDIF
  1592. RetArea=ALIAS()
  1593. IF OK=2
  1594.   IF TYPE('File')='C'
  1595.     SELE &File
  1596.   ENDIF
  1597. ENDIF
  1598. IF EMPTY(Mask)
  1599.   RETURN ( .T. )
  1600. ENDIF
  1601. IF TYPE('Mask')='C'
  1602.   SEEK TRIM(Mask)
  1603. ELSE
  1604.   SEEK Mask
  1605. ENDIF
  1606. OK=EOF()
  1607. SELE &RetArea
  1608. RETURN ( ! OK )
  1609.  
  1610. FUNCTION Confirm
  1611. * Syntax:  Confirm( <ExpL> [, <ExpC> ])
  1612. * Notes.:  Asks Y/N without get
  1613. PARA Changed,Text
  1614. PRIV I
  1615. I=PCOUNT()
  1616. IF I<1
  1617.   RETURN ( .T. )
  1618. ENDIF
  1619. IF TYPE('Changed')#'L'
  1620.   RETURN ( .T. )
  1621. ENDIF
  1622. IF I<2
  1623.   Text='Information has been altered.  Overwrite old data (Y/N)? '
  1624. ENDIF
  1625. @ 24,0
  1626. @ 24,0 SAY Text
  1627. DO COL2
  1628. ?? IF (Changed,'Y','N')
  1629. DO COL1
  1630. Key=0
  1631. DO WHIL ! Chr(Key) $ 'YyNnTtFf'+chr(13)+chr(3)
  1632.   Key=Inkey(0)
  1633. ENDD
  1634. @ 24,0
  1635. Changed=IF (Chr(Key) $ 'YyTt'+chr(13)+chr(3),.T.,.F.)
  1636. RETURN Changed
  1637.  
  1638. PROC SHOWREC
  1639. * Syntax:  DO SHOWREC WITH <Field List>, <Start Row>, <Start Col>, <Field Sep>
  1640. * Notes.:  The array of FLDS that are passed to this procedure must be the
  1641. *          NAMES of the fields in the database
  1642. PARA Flds,Y,X,Filler
  1643. PRIV I,J
  1644. I=PCOUNT()
  1645. IF i<2
  1646.   RETURN
  1647. ENDIF
  1648. IF I<3
  1649.   X=0
  1650. ENDIF
  1651. IF I<4
  1652.   Filler='│'
  1653. ENDIF
  1654. IF TYPE('Flds')='A'
  1655.   I=2
  1656.   FN=Flds[1]
  1657.   @ Y,X SAY &FN
  1658.   DO WHIL ! EMPTY(Flds[I]).AND.I<LEN(Flds)
  1659.     FN=Flds[I]
  1660.     IF COL()<78
  1661.       ?? Filler
  1662.       ?? &FN
  1663.     ENDIF
  1664.     I=I+1
  1665.   ENDDO
  1666. ELSE
  1667.   @ Y,X SAY &Flds
  1668. ENDIF
  1669. DO COL1
  1670. @ 0,10 SAY IF(Deleted(),'Deleted','       ')
  1671. RETURN
  1672.  
  1673. PROC LISTRECS
  1674. * Syntax:  DO ListRecs WITH <FieldLists>, <Filter>, <Start Row>, <Left Column>,
  1675. *          <Lines in Window>, <Field Separator>
  1676. * Notes.:  The array of FLDS that are passed to this procedure must be the
  1677. *          NAMES of the fields in the database.
  1678. PARA Flds,Filt,Y,X,Lines,Filler
  1679. PRIV I,J
  1680. I=PCOUNT()
  1681. IF i<1
  1682.   RETURN
  1683. ENDIF
  1684. IF I<2
  1685.   Filt=.T.
  1686. ENDIF
  1687. IF I<3
  1688.   Y=3
  1689. ENDIF
  1690. IF I<4
  1691.   X=0
  1692. ENDIF
  1693. IF I<5
  1694.   Lines=24-Y
  1695. ENDIF
  1696. IF I<6
  1697.   Filler='│'
  1698. ENDIF
  1699. I=0
  1700. RetRec=RecNo()
  1701. DO WHIL &Filt .AND. ! EOF().AND.I<Lines
  1702.   DO SHOWREC WITH Flds,Y+I,X,Filler
  1703.   I=I+1
  1704.   SKIP
  1705. ENDDO
  1706. GO RetRec
  1707. RETURN
  1708.  
  1709. PROCEDURE SELEREC
  1710. * Syntax:  DO SELEREC WITH <FieldList>, <Filter>, <Row>, <Col>, <Lines>,
  1711. *          <Filler>
  1712. * Notes.:  Uses the current data file
  1713. PARA Flds,Filt,Row,Col,Lines,Filler
  1714. PRIV X1,X2,Y1,Y2,I,DelStat
  1715. I=PCOUNT()
  1716. IF I<1
  1717.   RETURN
  1718. ENDIF
  1719. IF I<2
  1720.   Filt='.T.'
  1721. ENDIF
  1722. IF I<3
  1723.   Row=3
  1724. ENDIF
  1725. IF I<4
  1726.   Col=0
  1727. ENDIF
  1728. IF I<5
  1729.   Lines=24-Row
  1730. ENDIF
  1731. IF I<6
  1732.   Filler='║'
  1733. ENDIF
  1734. IF ! &Filt
  1735.   LOCA FOR &Filt
  1736.   IF EOF()
  1737.     @ 24,0 SAY 'No records found for &Filt'
  1738.     Inkey(0)
  1739.     RETU
  1740.   ENDIF
  1741. ENDIF
  1742. DelStat=STATUS('DELETED')
  1743. SET DELE OFF
  1744. Y1=Row-1
  1745. X1=Col
  1746. Y2=Y1+Lines
  1747. X2=79
  1748. FirstRec=RecNo()
  1749. * Since TR's CURSOR conflicted with another function that I had, I recompiled
  1750. * it as CURSOR2.
  1751. CALL CURSOR2 WITH "OFF"
  1752. DO COL1
  1753. CALL SCROLL2 WITH Y1,X1,Y2,X2,0,'U'
  1754. DO LISTRECS WITH Flds,Filt,Row,Col,Lines,Filler
  1755. Key=0
  1756. I=1
  1757. GO FirstRec
  1758. DO COL2
  1759. FirstField=Flds[1]
  1760. @ Row,Col SAY &FirstField
  1761. DO WHIL Key#13
  1762.   DO COL2
  1763.   @ Y1+I,X1 SAY &FirstField
  1764.   DO COL1
  1765.   Key=Inkey(0)
  1766.   TempRec=Recno()
  1767.   @ Y1+I,X1 SAY &FirstField
  1768.   DO CASE
  1769.   CASE Key=27 && Esc
  1770.     Key=13
  1771.   CASE Key=28 && F1
  1772.     SAVE SCREEN TO TEMPBUFF
  1773.     @  0,0 SAY '╔══════╤═══════════════════════════╗'
  1774.     @  1,0 SAY '║ Key  │          Result           ║'
  1775.     @  2,0 SAY '╟──────┼───────────────────────────╢'
  1776.     @  3,0 SAY '║ ─, │ next record               ║'
  1777.     @  4,0 SAY '║ ─, │ previous record           ║'
  1778.     @  5,0 SAY '║ PgUp │ next screen               ║'
  1779.     @  6,0 SAY '║ PgDn │ previous screen           ║'
  1780.     @  7,0 SAY '║ Home │ 1st record match          ║'
  1781.     @  8,0 SAY '║ Del  │ (un)delete current record ║'
  1782.     @  9,0 SAY '║ ──┘ │ select current record     ║'
  1783.     @ 10,0 SAY '║ F1   │ this screen               ║'
  1784.     @ 11,0 SAY '╚══════╧═══════════════════════════╝'
  1785.     @ 12,0 SAY '       Hit any key to continue'
  1786.     inkey(0)
  1787.     RESTORE SCREEN FROM TEMPBUFF
  1788.   CASE Key=1 &&HomeKey
  1789.     GO FirstRec
  1790.     CALL SCROLL2 WITH Y1,X1,Y2,X2,0,'U'
  1791.     DO LISTRECS WITH Flds,Filt,Row,Col,Lines,Filler
  1792.     I=1
  1793.   CASE Key=18 &&PgUp
  1794.     SKIP -Lines
  1795.     IF &Filt .AND. ! BOF()
  1796.       I=1
  1797.       CALL SCROLL2 WITH Y1,X1,Y2,X2,0,'U'
  1798.       DO LISTRECS WITH Flds,Filt,Row,Col,Lines,Filler
  1799.     ELSE
  1800.       GO TempRec
  1801.     ENDIF
  1802.   CASE Key=3 &&PgDn
  1803.     SKIP Lines
  1804.     IF &Filt .AND. ! EOF()
  1805.       I=1
  1806.       CALL SCROLL2 WITH Y1,X1,Y2,X2,0,'U'
  1807.       DO LISTRECS WITH Flds,Filt,Row,Col,Lines,Filler
  1808.     ELSE
  1809.       GO TempRec
  1810.     ENDIF
  1811.   CASE (Key=24.OR.Key=4).AND.! EOF() && Down or Right arrow
  1812.     I=I+1
  1813.     SKIP
  1814.     IF &Filt .AND. ! EOF()
  1815.       IF I>Lines
  1816.         I=I-1
  1817.         CALL SCROLL2 WITH Y1,X1,Y2,X2,1,'U'
  1818.         DO SHOWREC WITH Flds,Y1+I,X1,Filler
  1819.       ENDIF
  1820.     ELSE
  1821.       I=I-1
  1822.       GO TempRec
  1823.     ENDIF
  1824.   CASE (Key=5.OR.Key=19).AND.! BOF() && Up or Left arrow
  1825.     I=I-1
  1826.     SKIP -1
  1827.     IF &Filt .AND. ! BOF()
  1828.       IF I<1
  1829.         I=I+1
  1830.         CALL SCROLL2 WITH Y1,X1,Y2,X2,1,'D'
  1831.         DO SHOWREC WITH Flds,Y1+I,X1,Filler
  1832.       ENDIF
  1833.     ELSE
  1834.       I=I+1
  1835.       GO TempRec
  1836.     ENDIF
  1837.   CASE Key=7 && Delete key
  1838.     IF DELETED()
  1839.       RECA
  1840.     ELSE
  1841.       DELETE
  1842.     ENDIF
  1843.   ENDC
  1844. ENDDO
  1845. DO COL1
  1846. CALL CURSOR2 WITH "ON"
  1847. SET DELE &DelStat
  1848. RETURN
  1849.  
  1850. PROCEDURE JJMA
  1851. IF ISCOLOR()
  1852.   SET COLO TO B+
  1853. ELSE
  1854.   SET COLO TO W+
  1855. ENDIF
  1856. CLEA
  1857. CALL CURSOR2 WITH "OFF"
  1858. TEXT
  1859.  
  1860.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄          ▄▄▄▄         ▄▄▄
  1861.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄        ▄▄▄▄▄       ▄▄▄▄▄▄▄
  1862.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄▄      ▄▄▄▄▄▄      ▄▄▄▄ ▄▄▄▄
  1863.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄▄▄    ▄▄▄▄▄▄▄     ▄▄▄▄   ▄▄▄▄
  1864.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄ ▄▄  ▄▄ ▄▄▄▄▄    ▄▄▄▄     ▄▄▄▄
  1865.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄  ▄▄▄▄  ▄▄▄▄▄   ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄
  1866.               ▄▄▄▄▄          ▄▄▄▄▄   ▄▄▄▄▄   ▄▄   ▄▄▄▄▄   ▄▄▄▄▄     ▄▄▄▄▄
  1867.       ▄▄▄▄▄   ▄▄▄▄▄  ▄▄▄▄▄   ▄▄▄▄▄   ▄▄▄▄▄        ▄▄▄▄▄   ▄▄▄▄▄     ▄▄▄▄▄
  1868.       ▄▄▄▄▄   ▄▄▄▄▄  ▄▄▄▄▄   ▄▄▄▄▄   ▄▄▄▄▄        ▄▄▄▄▄   ▄▄▄▄▄     ▄▄▄▄▄
  1869.        ▄▄▄▄▄▄▄▄▄▄▄    ▄▄▄▄▄▄▄▄▄▄▄    ▄▄▄▄▄        ▄▄▄▄▄   ▄▄▄▄▄     ▄▄▄▄▄
  1870.          ▄▄▄▄▄▄▄        ▄▄▄▄▄▄▄      ▄▄▄▄▄        ▄▄▄▄▄   ▄▄▄▄▄     ▄▄▄▄▄
  1871. ENDTEXT
  1872. IF ISCOLOR()
  1873.   SET COLO TO W+
  1874. ELSE
  1875.   SET COLO TO W
  1876. ENDIF
  1877. TEXT
  1878.  
  1879.                               COMPUTER APPLICATIONS
  1880.  
  1881.  
  1882.                    John J. McMullen Associates, Incorporated.
  1883.                            Century Building, Suite 715
  1884.             2341 Jefferson Davis Highway, Arlington, Virginia  22202
  1885.                                 (703) 521 - 6500
  1886. ENDTEXT
  1887. DO COL1
  1888. inkey(10)
  1889. CALL CURSOR2 WITH "ON"
  1890. RETU
  1891.  
  1892. *************************
  1893. *  External declarations:
  1894. *************************
  1895.  
  1896. ** These external utilities are from DL1B.ARC - if you don't have it, get it!
  1897.  
  1898. * EXTERNAL untrim,dtow,getkey, dial, set_page, reset, prtscr, get_mode
  1899. * EXTERNAL get_page, chdir, mkdir, rmdir, set_mode, sysmem, cursor, cls
  1900. * EXTERNAL curr_drive, set_time, curr_dir, set_date, setdate, set_drive, subset
  1901. * EXTERNAL isupper, islower, ltow, subsets, allalpha, allnum, allascii
  1902. * EXTERNAL timeh, isdir, isprint
  1903.  
  1904. * EOP: EXTENDB2.PRG
  1905.