home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / FOXPRO / PRE307 / LIBRARY.PRE < prev    next >
Text File  |  1990-03-27  |  35KB  |  1,471 lines
  1. Note Defines and includes
  2. *
  3. #include keydefs.inc
  4. #include stddefs.inc
  5. #define dummy ''
  6. #define maxlen(x,y) max(len(alltrim(x)),len(alltrim(y)))
  7.  
  8. note Append/Seek Blank
  9. *appenblank
  10. function appenblank
  11.   private keyfield,x,tempflt
  12.   tempflt = dbfilter()
  13.   set filter to
  14.   set deleted off
  15.   keyfield = indexkey(0)
  16.   if .not. empty(keyfield)                       && if there is a key:
  17.     seek blank(&keyfield)
  18.     if found()
  19.       recall
  20.       blankit()
  21.     else
  22.       append blank
  23.     endif
  24.   else
  25.     locate for deleted()
  26.     if found()
  27.       recall
  28.       blankit()
  29.     else
  30.       append blank
  31.     endif
  32.   endif
  33.   set deleted on
  34.   set filter to &tempflt
  35. return(0)
  36.  
  37. note Blank Record
  38. *blankit
  39. function blankit
  40.   private i
  41.   for i = 1 to fcount()
  42.     x = field(i)
  43.     replace &x with blank(&x)
  44.   next 
  45. return 0
  46.  
  47.  
  48.  
  49.  
  50. note Box Center
  51. *boxcenter
  52. function boxcenter
  53.   * Syntax:   boxcenter([<expN1>],[<expN2>],[<expN3>],[<expN4>],[<expN5>],[<expN6>],[<expN7>])
  54.   * Centers a box of width <expN1> and height <expN2> starting at 
  55.   *   row <expN3>, column <expN4>.
  56.  
  57.   parameters width,height,row,col,row2,col2,boxtype
  58.  
  59.   private winwidth,winheight,fcol,tcol
  60.  
  61.   if type([height]) <> 'N'
  62.     height = 24
  63.   endif
  64.  
  65.   if type([row]) <> 'N'
  66.     row = int((24 - height)/2)
  67.   endif
  68.  
  69.   if type([width]) <> 'N'
  70.     width = 80
  71.   endif
  72.  
  73.   if type([boxtype]) <> 'N'
  74.     boxtype = 2
  75.   endif
  76.  
  77.   if type([col]) <> 'N'
  78.     col = 0
  79.   endif
  80.  
  81.   winwidth = 80
  82.   winheight = 24
  83.  
  84.   if width >= winwidth       &&  Too long to center
  85.     fcol = col
  86.   else
  87.     fcol = col+int((winwidth - width)/2)
  88.   endif
  89.   tcol = fcol + width - 1
  90.   if boxtype = 2 .or. boxtype = 4
  91.     @ row,fcol to row+height-1,tcol double
  92.   else
  93.     @ row,fcol to row+height-1,tcol
  94.   endif
  95.   if boxtype = 3 .or. boxtype = 4
  96.     shadow(row,fcol,row+height-1,tcol)
  97.   endif
  98. return fcol                                      && boxcenter
  99.  
  100.  
  101. note Box Menu
  102. *boxmenu
  103. *
  104. * Add parameters for message,message location, box around it (y/n).
  105. * Add parameters for type of box (or no box)
  106. *
  107. function boxmenu
  108.   parameters array,row,col,height,width,boxtitle,quick,initch,truth,scrnrest
  109.   private row2,col2,i,choice,scrn,titcol,initwin
  110.   public boxquick
  111.  
  112.  
  113.  
  114.   if type([height]) <> 'N'
  115.     height = min(len(array)+2,23)
  116.   endif
  117.  
  118.   if type([row]) <> 'N'
  119.     row = int((24 - height)/2)
  120.   endif
  121.  
  122.   row2 = min(row + height - 1,24)
  123.  
  124.   if type([quick]) <> 'L'
  125.     boxquick = .t.
  126.    else
  127.      boxquick = quick
  128.   endif
  129.  
  130.   if boxquick
  131.     boxstring = ''
  132.     for i = 1 to len(array)
  133.       boxstring = boxstring + upper(substr(array[i],1,1))
  134.     next
  135.   endif
  136.  
  137.   if type([boxtitle]) <> 'C'
  138.     boxtitle = ''
  139.   else
  140.     boxtitle = space(2) + alltrim(boxtitle) + space(2)
  141.   endif
  142.  
  143.   if type([width]) <> 'N'
  144.     width = length(array) + 4
  145.   endif
  146.  
  147.   if .not. empty(boxtitle) .and. width < len(boxtitle)+4
  148.     width = min(len(boxtitle)+4,80)
  149.     if width < len(boxtitle)+4
  150.       boxtitle = space(2) + substr(alltrim(boxtitle),1,width - 4) + space(2)
  151.     endif
  152.   endif
  153.  
  154.   if type([col]) <> 'N'
  155.     col = int((79 - width)/2)
  156.   endif
  157.  
  158.   col2 = min(col + width  - 1,79)
  159.  
  160.   if type([truth]) <> 'L' .and. type([truth]) <> 'A'
  161.     truth = .t.
  162.   endif
  163.  
  164.   if type([scrnrest]) <> 'L'
  165.     scrnrest = .t.
  166.   endif
  167.  
  168.   if type([initch]) <> 'N'
  169.     initch = 1
  170.   endif
  171.  
  172.   *  if type([initwin]) <> 'N'
  173.     initwin = 0
  174.   *  endif
  175.  
  176.   if row2 - row < 2 .or. col2 - col < 2 .or. row < 0 .or. row > 24 ;
  177.      .or. row2 < 0 .or. row2 > 24 .or. col < 0 .or. col > 79 ;
  178.      .or. col2 < 0 .or. col2 > 79
  179.      return 0
  180.    endif
  181.   if scrnrest
  182.     scrn = savescreen(row,col,row2+2,col2+2)
  183.   endif
  184.   @ row,col clear to row2,col2
  185.   @ row,col to row2,col2 double
  186.   shadow(row,col,row2,col2)
  187.   if .not. empty(boxtitle)                                
  188.     center(boxtitle,row,col,col2)               
  189. *    @ row,titcol-1 , row + 2,titcol + len(boxtitle)+2 box "┌─┐╞┘─└╡"
  190.   endif
  191.   choice = achoice(row+1,col+2,row2-1,col2-2,array,truth,'boxchoice',initch,initwin)
  192.    release boxquick
  193.   if scrnrest
  194.     restscreen(row,col,row2+2,col2+2,scrn)
  195.   endif
  196. return choice
  197.  
  198. function boxchoice
  199.   parameters mode,choice,position
  200.   private retcode
  201.   if mode = 0
  202.      retcode = 2
  203.   elseif mode = 1
  204.     keypress(ctrl_pgdn)
  205.     retcode = 2
  206.   elseif mode = 2
  207.     keypress(ctrl_pgup)
  208.     retcode = 2
  209.   elseif mode = 3
  210.     if lastkey() = left
  211.       keypress(up)
  212.       retcode = 2
  213.     elseif lastkey() = right
  214.       keypress(dn)
  215.       retcode = 2
  216.     elseif lastkey() = esc
  217.       retcode = 0
  218.     elseif lastkey() = home
  219.       keypress(ctrl_pgup)
  220.       retcode = 2
  221.     elseif lastkey() = endkey
  222.       keypress(ctrl_pgdn)
  223.       retcode = 2
  224.     elseif lastkey() = enter
  225.       retcode = 1
  226.     elseif boxquick
  227.       if upper(chr(lastkey()))$boxstring
  228.         keyboard chr(enter)
  229.       endif
  230.       retcode = 3
  231.     else
  232.       retcode = 3
  233.     endif
  234.   else
  235.     retcode = 2
  236.   endif
  237.   if type('helpchoice') = 'N'
  238.     helpchoice = position
  239.   endif
  240. return retcode
  241. ***************** end boxmenu
  242.  
  243.  
  244. note Box Message
  245. *boxmsg
  246. function boxmsg
  247.  
  248.   * add a parameter to stack boxes (i.e. leave top or bottom open) ????
  249.   * add a parameter for box type 
  250.  
  251.   parameters message,row,col,boxtime,boxcolor
  252.  
  253.   private scrn,tempcolor,row2,col2,height,i,msg,curs
  254.   curs = cursor()
  255.  
  256.   set cursor off
  257.  
  258.   if type([message]) = 'A'
  259.     height = min(len(message)+2,23)
  260. *   width = 0
  261. *   for i = 1 to len(message)
  262. *     width = max(width,len(message[i]))
  263. *   next
  264. *   width = min(width + 4,80)
  265.   elseif type([boxtime]) = 'N'
  266.     if boxtime = 0
  267.       if type([message]) <> 'C'
  268.         message = 'Press Any key to continue'
  269.       else
  270.         msg = message
  271.         private message[2]
  272.         message[1] = msg
  273.         message[2] = 'Press Any key to continue'
  274. *        width = maxlen(message[1],message[2]) + 4
  275.         height = 4
  276.       endif
  277.     endif
  278.   endif
  279.  
  280.   width = min(length(message)+4,80)
  281.  
  282.   if type([message]) = 'C'
  283. *   width = min(len(message)+4,80)
  284.     height = 5
  285.   endif
  286.  
  287.   if type([row]) <> 'N'
  288.     row = int((24 - height)/2)
  289.   else
  290.     if row +height > 22 .or. row < 0
  291.       row = int((24 - height)/2)
  292.     endif
  293.   endif
  294.  
  295.   if type([col]) <> 'N'
  296.     col = int((79 - width)/2)
  297.   else
  298.     if col+width > 79 .or. col < 0
  299.       col = int((79 - width)/2)
  300.     endif
  301.   endif
  302.  
  303.   row2 = min(row + height - 1 ,24)
  304.   col2 = min(col + width - 1,79)
  305.   tempcolor = setcolor()
  306.  
  307.   if type([boxcolor]) <> 'C'
  308.     boxcolor = setcolor()
  309.   endif
  310.   if type([boxtime]) = 'N'                       && If a time was passed,
  311.     scrn = boxsave(row,col,row2,col2,boxcolor)   && save portion of screen
  312.   else                                           && else
  313.     save screen to scrn                          && save whole screen
  314.     boxsave(row,col,row2,col2,boxcolor)
  315.   endif
  316.  
  317.  
  318.   if type([message]) = 'A'
  319.     for i = 1 to height -2
  320.       @ row+i,col+2 say message[i]
  321.     next
  322.   else
  323.     @ row+2,col+2 say message
  324.   endif
  325.  
  326.   if type([boxtime]) = 'N'
  327.     inkey(boxtime)
  328.   endif
  329.   if type([boxcolor]) = 'C'
  330.     setcolor(tempcolor)
  331.   endif
  332.   if type([boxtime]) = 'N'
  333.     * setcolor(tempcolor)
  334.     restscreen(row,col,row2+2,col2+2,scrn)
  335.   endif
  336.   set cursor (curs)
  337.   return scrn
  338.  
  339. ******************* end boxmsg
  340.  
  341. note Build Database
  342. *build
  343. function build
  344.   parameters dbffile,dict
  345.   private xsel
  346.  
  347.   if .not. file_name(@dbffile,'DBF')
  348.     return .f.
  349.   endif
  350.  
  351. if file(dbffile)                                 && if already exists,return.
  352.   return .t.                                     && (change this to test structure)
  353. endif                                            && * * * * * * *   * *
  354.  
  355.   if type([dict]) = 'C'                          && dbf name passed.
  356.     dbdict = dict
  357.     fcount = lastrec()                           && Number of fields in dbf.
  358.   elseif type([dict]) = 'A'                      && Array passed.
  359.     fcount = len(dict)                          && Number of fields from array.
  360.   else
  361.     return .f.                                   && bad parameter.
  362.   endif
  363. private field[fcount],ftype[fcount],fwidth[fcount]
  364.  
  365.   xsel = select()
  366.   select 0
  367.   if type([dict]) <> 'A'                         && Dict passed as dbf.
  368.     create (dbffile) from (dict)
  369.   else
  370.     create t_e_m_p
  371.     use t_e_m_p
  372.     for i = 1 to fcount                          && dict passed as array
  373.       append blank
  374.       replace field_name with substr(dict[i],1,12)
  375.       replace field_type with substr(dict[i],13,1)
  376.       replace field_len with val(substr(dict[i],15,17))
  377.     next
  378.     use
  379.     create (dbffile) from t_e_m_p
  380.     erase "t_e_m_p.dbf"
  381.   endif  
  382.   use
  383.   select (xsel)
  384. return (file(dbffile))
  385.  
  386. ******************* end build
  387.  
  388.  
  389. note Center a string at a row, between optional columns
  390. *center
  391. function center
  392.   * Syntax:   center(<expC>[,<expN1>][,<expN2>][,<expN3>])
  393.   * Centers <expC> at row <expN1> between column <expN2> and column <expN3>.
  394.   parameters string,row,col,col2
  395.   private ccol,width
  396.   if type([col]) <> 'N'
  397.     col = 0
  398.   endif
  399.   if type([col2]) <> 'N'
  400.     col2 = 79
  401.   endif
  402.   if type([row]) <> 'N'
  403.     row = row()
  404.   endif
  405.   width = col2 - col + 1
  406.   if len(string) >= width       &&  Too long to center
  407.     ccol = col
  408.   else
  409.     ccol =col+int((width - len(string))/2)
  410.   endif
  411.   @ row,ccol say string
  412. return ccol
  413.  
  414.  
  415. note File Date
  416. *filedate
  417. * Syntax..: filedate( <expC> )
  418. * Returns.: Date of file <expC>.
  419.  
  420. function filedate
  421. parameter fname
  422.  
  423. *-- make sure a parameter was passed
  424. if pcount() = 1                                  && If parameter passed,
  425.    private fdate[1]                              && declare date array
  426.    if adir( fname, '', '', fdate ) = 1           && fill date array
  427.       return fdate[1]                            && return date.
  428.    endif
  429. endif
  430. return ctod('  /  /  ')                          && No parameter passed.
  431.  
  432. ********************************* filedate
  433.  
  434. note File Date & Time
  435. *fdatetime
  436. * Syntax..: fdatetime(<expC>,@<expC>,@expD)
  437. * Returns.: .t./.f. if file found/not found.
  438.  
  439. function fdatetime
  440.  
  441. parameters fname,fdate,ftime
  442. private fd[1],ft[1]
  443.  
  444.  
  445.   if adir(fname, '', '', fd,ft) <> 1
  446.       return .f.
  447.   endif
  448.  
  449.   if type([fdate]) = 'D'
  450.     fdate = fd[1]
  451.   endif
  452.  
  453.   if type([ftime]) = 'C'
  454.     ftime = ft[1]
  455.   endif
  456.  
  457. return .t.
  458.  
  459. ********************************* fdatetime
  460.  
  461. note Check for Valid File Name
  462. *file_name
  463. function file_name                               && test for valid filename
  464.   parameters fname,ext
  465.   if empty(fname)
  466.     return .f.
  467.   endif
  468.   ext = '.' + upper(ext)
  469.   fname = upper(fname)
  470.   if at('.',fname) = 0
  471.     fname = fname + ext
  472.     return .t.
  473.   elseif at(ext,fname) = 0
  474.     return .f.
  475.   endif
  476. return .t.
  477.  
  478. ********************************* file_name
  479.  
  480. note File Time
  481. *filetime
  482. * Syntax..: filetime( <expC> )
  483. * Returns.: Character time string of file <expC>.
  484.  
  485. function filetime
  486.  
  487. parameters fname
  488.  
  489. if pcount() = 1                                  && If parameter passed,
  490.    private ftime[1]                              && file time array
  491.    if adir( fname, '', '', '', ftime ) = 1       && fill time array
  492.       return ftime[1]                            && return time string.
  493.    endif
  494. endif
  495. return space(8)                                  && No parameter passed.
  496.  
  497. ******************************* filetime
  498.  
  499. note Fill Description array.
  500. *filldesc
  501. function filldesc
  502.   parameters field,descrip,dbdict
  503.   private hasdict,hold,i,fcount
  504.  
  505.   fcount = len(field)
  506.   afill(descrip,'')                              && Initialize descrip array
  507.  
  508.   hasdict = if(pcount() > 2,(if(.not. empty(dbdict),.t.,.f.)),.f.) 
  509.  
  510.   * Add option to ignore fields that are not in dict ???
  511.   if hasdict                                     && Get dict. descriptions.
  512.     private filtname
  513.     filtname = alias()                           && alias name must be filename
  514.     hold = select()                              && Save the work area.
  515.     select 0       
  516.     use (dbdict)                                 && Open dictionary.
  517.     if type('dbfile') = 'C'                      && If dict. has 'dbfile' field
  518.       set filter to dbfile = filtname            && get the right fields.
  519.       go top
  520.     endif
  521.     do while .not. eof()
  522.       i = ascan(field,upper(trim(field_name)))   && Find field name from dict.
  523.       if i > 0                                   && If found,
  524.         descrip[i] = descript                    && Put it in the array.
  525.       endif
  526.       skip
  527.     enddo
  528.     use                                          && Close dictionary.
  529.     select (hold)                                && Select original work area.
  530.   endif 
  531.   for i = 1 to fcount
  532.     if empty(descrip[i])
  533.       descrip[i] = field[i]
  534.     endif
  535.   next
  536.  
  537. return .t.                                       && filldesc
  538.  
  539.  
  540.  
  541. note Generic Edit Routine
  542. * gedit
  543. function  gedit
  544.  
  545.   * add a picture/valid parameter !!!!!
  546.   * change this to use memory variables ????
  547.   * change to allow passing row,col info.
  548.  
  549.   #define trow 1
  550.   #define brow 22
  551.  
  552.   parameters dict,descrip,eduv,carrywhat,pix,vld
  553.   * parameters are optional
  554.   * dict is the dictionary (dbf or array) with field descriptions
  555.   * if dict is missing or null ('') then field names are displayed
  556.   * eduv is the edit mode:
  557.   *   A - Add
  558.   *   C - Add with carry
  559.   *   E - Edit
  560.   *   D - Delete
  561.   *   U - Undelete
  562.   *   V - View 
  563.   * if eduv is missing then 'E' is assumed.
  564.   * Carrywhat (valid only if eduv is 'C') is a field name or array of 
  565.   *   fieldnames to carry from the current record to the new record.
  566.   *   if carrywhat is missing then all fields are carried.
  567.   * Vld is an array of expressions for 'valid' parameter of get.
  568.   * gedit assumes appropriate filters are set for delete and undelete.
  569.   * To limit Add to new records only, set filter before calling gedit.
  570.   *   Example: rec = lastrec(). set filter to recno() > rec
  571.  
  572.   private i,n,fcount,fx,lk,nk,yn,gedmsg,gpic,gvld
  573.  
  574.   set cursor off
  575.   set exact on
  576.   if type([eduv]) = 'C'
  577.     eduv = upper(eduv)
  578.   else
  579.     eduv = 'E'
  580.   endif
  581.  
  582.   if type([dict]) = 'C'                          && dbf name passed.
  583.     dbdict = dict
  584.     fcount = fcount()                            && Number of fields in dbf.
  585.   elseif type([dict]) = 'A'                      && Array passed.
  586.     fcount = len(dict)                          && Number of fields from array.
  587.   else
  588.     dbdict = ''
  589.     fcount = fcount()                            && Number of fields in dbf.
  590.   endif
  591.  
  592.   * 
  593.   nk = ' '
  594.   yn = 'N'
  595. *  fcount = fcount()                              && Number of fields in dbf.
  596.   if type([descrip]) <> 'A'
  597.     private descrip[fcount]
  598.   endif
  599.   private field[fcount],ftype[fcount],fwidth[fcount]
  600.   private bop[10],eop[10]                        && limit of 10 screens.
  601.  
  602.  
  603.   if eduv $ 'EVAC'
  604.     set function 7 to chr(ctrl_w)+'7'
  605.     set function 8 to chr(ctrl_w)+'8'
  606.     set function 10 to chr(ctrl_w)
  607.     if eduv $ 'AC'
  608.       set function 9 to chr(ctrl_w)+'9'
  609.       nk = '9'
  610.  *     eduvmsg = ' F9: ADD  '
  611.       gedmsg = "│         F9: ADD Another Record         │ F7/F8: Prev/Next Screen │ F10: Done │"
  612. *      gedmsg = "│" +eduvmsg + "│ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
  613.     else
  614.       eduvmsg = if(eduv = 'E','   EDIT   ','   VIEW   ')
  615.       gedmsg = "│" +eduvmsg + "│ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
  616.     endif
  617. *   gedmsg = "│ F1: HELP │ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
  618.   elseif eduv $ 'DU'
  619.     if eduv = 'D'
  620.       eduvmsg = '  DELETE  '
  621.     else
  622.       eduvmsg = ' UNDELETE '
  623.     endif
  624.     gedmsg = "│" + eduvmsg + "│                   CONFIRM (Y/N):                                  │"
  625.   else
  626.     * Invalid parameter
  627.     return .f.
  628.   endif
  629.  
  630.   if type([dict]) <> 'A'                         && Dict passed as file or no params
  631.     private descrip[fcount]
  632.     afields(field,ftype,fwidth)                  && Put field names in arrays.
  633.     filldesc(field,descrip,dbdict)
  634.   else
  635.     for i = 1 to fcount                          && dict passed as array
  636.       field[i] = substr(dict[i],1,12)
  637.       ftype[i] = substr(dict[i],13,1)
  638.       fwidth[i] = val(substr(dict[i],15,17))
  639.     next
  640.   endif
  641.  
  642.   if type([descrip]) <> 'A'                      && field is array,but no descrip
  643.     private descrip[fcount]
  644.     for i = 1 to fcount
  645.       descrip[i] = field[i]
  646.     next
  647.   endif
  648.  
  649.   @ trow,0 clear
  650.   @ 24,0 say gedmsg
  651.   @ trow,0 to 23,79
  652.   do while .t.
  653.     set cursor on
  654.     if eduv $ 'AC' .and. nk = '9'
  655.       if .not. type([carrywhat]) $ 'AC'
  656.         gadd(eduv)
  657.       else
  658.         gadd(eduv,carrywhat)
  659.       endif
  660.     endif
  661.     i = 1
  662.     n = 1
  663.     nk = ' '
  664.     bop[1] = 1
  665.     @ trow,70 say       '┐Page:    '
  666.     @ trow+1,70 say     '└────────┐'
  667.     @ trow,77 say str(n,3)
  668. *    center (eduvmsg,trow)
  669.     @ trow+2,1 clear to 22,78
  670.     @ trow+1,1 say recno()
  671.     @ trow+2,1 say ''
  672.     do while i <= fcount
  673.       fx = field[i]
  674.       @ row()+1,1 say trim(descrip[i]) + ' '
  675.       gpic = ''
  676.       if type([pix]) = 'A'
  677.         if .not. empty(pix[i])
  678.           gpic = '"' + pix[i] + '"'
  679.         endif
  680.       elseif type([pix]) = 'C'
  681.         gpic = '"' + pix + '"'
  682.       endif
  683.       if empty(gpic) .and. (fwidth[i]+len(trim(descrip[i])) > 77 .or. ftype[i] == 'M')
  684.         gpic = '"@s77"'
  685.         @ row()+1,1 say '' 
  686.       endif
  687.       if type([vld]) = 'A'
  688.         gvld = vld[i]
  689.       else
  690.         gvld = ''
  691.       endif
  692.       if .not. empty(gpic)
  693.         if empty(gvld)
  694.           @ row(),col() get &fx picture &gpic
  695.         else
  696.           @ row(),col() get &fx picture &gpic valid &gvld
  697.         endif
  698.  
  699.       else
  700.         if .not. empty(gvld)
  701.           @ row(),col() get &fx valid &gvld
  702.         else
  703.           @ row(),col() get &fx
  704.         endif
  705.       endif
  706.       if row() >= brow
  707.         if eduv $ 'DU'                           && if delete or undelete
  708.           exit                                   && bail out after one screen.
  709.         endif
  710.         read
  711.         set cursor off
  712.         lk = lastkey()
  713.         nk = chr(inkey())
  714.         eop[n] = i
  715.         if lk = esc
  716.           exit
  717.         elseif nk = '7'
  718.           n = if(n<2,1,n-1)
  719.           i = bop[n] - 1
  720.         elseif nk = '8'
  721.           if i < fcount
  722.             n = n + 1 
  723.           endif
  724.           bop[n] = eop[if(n<2,1,n-1)] + 1
  725.           eop[n] = i
  726.         else
  727.           exit
  728.         endif
  729.         @ 2,1 clear to 22,78
  730.         @ 0,77 say str(n,3)
  731.       endif
  732.       i = i + 1
  733.     enddo
  734.     if eduv $ 'DU'
  735.       clear gets
  736.       yn = 'N'
  737.       @ 24,53 get yn picture "Y"
  738.     endif
  739.     read
  740.     set cursor off
  741.     lk = lastkey()
  742.     nk = chr(inkey())
  743.     clear typeahead
  744.     if eduv $ 'DU'
  745.       if lk = esc
  746.         exit
  747.       endif
  748.       if yn = 'Y'
  749.         if eduv = 'D'
  750.           delete
  751.         else
  752.           recall
  753.         endif
  754.       endif
  755.       skip
  756.       if eof()
  757.         exit
  758.       endif
  759.     elseif eduv $ 'EVAC'
  760.       if eduv $ 'AC'
  761.         if lk = esc
  762.           blankit()
  763.           delete
  764.           exit
  765.         elseif isblank()
  766.           delete
  767.         endif
  768.       endif
  769.       do case
  770.         case lk = esc
  771.           exit
  772.         case lk = ctrl_w .and. nk $ '789'
  773.           loop
  774.         case lk = ctrl_w
  775.           exit
  776.         case eduv $ 'AC'
  777.           loop
  778.         case lk = pgdn .or. lk = enter
  779.           skip
  780.           if eof()
  781.             go bottom
  782.           endif
  783.         case lk = pgup
  784.           if .not. bof()
  785.             skip -1
  786.           endif
  787.       endcase
  788.     endif
  789.   enddo
  790.   set cursor off
  791. return .t.
  792.  
  793. function  gadd
  794.  
  795.   parameters eduv,whatcarry
  796.  
  797.   * Called by gedit.
  798.  
  799.   private i
  800.  
  801.   if pcount() < 1
  802.     carry = .f.
  803.   else
  804.     carry = (upper(eduv) = 'C')
  805.   endif
  806.   if carry
  807.     if pcount() = 2                              && If whatcarry exists
  808.        if type([whatcarry]) <> 'A'               && and it's not an array..
  809.          private tempvar
  810.          tempvar = &whatcarry
  811.          appenblank()
  812.          replace &whatcarry with tempvar
  813.        else                                      && else if it is an array..
  814.           for i = 1 to len(&whatcarry)
  815.             private &whatcarry[i]
  816.             &whatcarry[i] = &whatcarry[i]
  817.           next
  818.           appenblank()
  819.           for i = 1 to len(&whatcarry)
  820.             replace m->&whatcarry[i] with &whatcarry[i]
  821.           next
  822.        endif
  823.     else                                         && Carry but no whatcarry,
  824.       fcount = fcount()                          && carry all fields.
  825.     * private adfield[fcount],adfwidth[fcount]
  826.     * afields(adfield,dummy,adfwidth)
  827.       for i = 1 to fcount
  828.         x = field[i]
  829.         m->&x = &x
  830.       next 
  831.       appenblank()
  832.       for i = 1 to fcount
  833.         x = field[i]
  834.         replace &x with m->&x
  835.       next 
  836.     endif
  837.   else
  838.     appenblank()
  839.   endif
  840. return .t.
  841.  
  842. ********************************************************************
  843.  
  844.  
  845. note Horizontal Bar (double)
  846. *hbar2
  847. function hbar2
  848.   parameters row,lcol,rcol,p4,p5,p6,p7,p8,p9,p10
  849.   private i
  850.   if type([lcol]) <> 'N'
  851.     lcol = 0
  852.   endif
  853.   if type([rcol]) <> 'N'
  854.     rcol = 79
  855.   endif
  856.   if type([row]) <> 'N'
  857.     row = row()
  858.   endif
  859.   @ row,lcol+1 to row,rcol-1 double
  860.   @ row,lcol say chr(204)                        && ╠
  861.   @ row,rcol say chr(185)                        && ╣
  862.   if pcount() > 3
  863.     for i = 4 to pcount()
  864.       x = 'p'+alltrim(str(i))
  865.       @ row,&x say chr(206)                      && ╬
  866.     next
  867.   endif
  868. return .t.
  869.  
  870. note Horizontal Bar (single)
  871. *hbar
  872. function hbar
  873.   parameters row,lcol,rcol,p4,p5,p6,p7,p8,p9,p10
  874.   private i
  875.   if type([lcol]) <> 'N'
  876.     lcol = 0
  877.   endif
  878.   if type([rcol]) <> 'N'
  879.     rcol = 79
  880.   endif
  881.   if type([row]) <> 'N'
  882.     row = row()
  883.   endif
  884.   @ row,lcol+1 to row,rcol -1          
  885.   @ row,lcol say chr(195)
  886.   @ row,rcol say chr(180)
  887.   if pcount() > 3
  888.     for i = 4 to pcount()
  889.       x = 'p'+alltrim(str(i))
  890.       @ row,&x say chr(197)
  891.     next
  892.   endif
  893. return .t.
  894.  
  895.  
  896. note Is Record Blank ?
  897. *isblank
  898. function isblank
  899.   private i
  900.   for i = 1 to fcount()
  901.     x = field(i)
  902.     if .not. empty(&x)
  903.       return .f.
  904.     endif
  905.   next
  906. return .t.
  907.  
  908.  
  909. note Prompt for key field to search on
  910. *keyprompt
  911. function keyprompt
  912.   *
  913.   * if keyfield missing, can I figure out the key ????
  914.   *
  915.   parameters keyfield,keydesc,row,col,action,vld
  916.  
  917.   private retcd,scrn,kcolor,row2,col2,i,width,height,fstring,sstring
  918.   private message,fieldlen
  919.  
  920.   message = "(Press Esc to return to menu)"
  921.  
  922.   fieldlen = length(keyfield)
  923.   if .not. type('keydesc') $ 'AC'
  924.     keydesc = ''
  925.   endif
  926.   desclen = length(keydesc)
  927.   if type([keyfield]) = 'A'
  928.     height = min(len(keyfield)+4,21)
  929.   else
  930.      height = 5
  931.   endif
  932.   width = min(fieldlen + desclen + 6,78)
  933.   width = max(width,len(message)+4)
  934.   if type([col]) <> 'N'
  935.     col = int((77 - width)/2)
  936.   else
  937.     if col+width > 77 .or. col < 0
  938.       col = int((77 - width)/2)
  939.     endif
  940.   endif
  941.  
  942.   if type([row]) <> 'N'
  943.     row = int((22 - height)/2)
  944.   else
  945.     if row + height > 20 .or. row < 0
  946.       row = int((22 - height)/2)
  947.     endif
  948.   endif
  949.  
  950.   row2 = min(row + height - 1 ,22)
  951.   col2 = min(col + width - 1,77)
  952.   scrn = savescreen(row,col,row2+2,col2+2)
  953.   kcolor = setcolor()
  954.   setcolor('n/bg,n/w')
  955.   @ row+1,col+1 clear to row2-1,col2-1
  956.   @ row,col to row2,col2 double
  957.   shadow(row,col,row2,col2)
  958.   do while .t.
  959.     set cursor on
  960.     if type([keyfield]) = 'A'
  961.       for i = 1 to len(keyfield)
  962.         if type('keydesc') = 'A'
  963.           @ row+i,col+2 say keydesc[i] get keyfield[i] picture "@K"
  964.         else
  965.           @ row+i,col+2 say keydesc get keyfield[i] picture "@K"
  966.         endif
  967.       next                                    
  968.     else
  969.       if type([vld]) = 'U'
  970.         @ row+1,col+2 say keydesc get keyfield picture "@K"
  971.       else
  972.         @ row+1,col+2 say keydesc get keyfield picture "@K" valid &vld
  973.       endif
  974.     endif
  975.     @ row()+1,col+2 say message
  976.     read
  977.     set cursor off
  978.     if lastkey() = esc
  979.       retcd = .f.
  980.       exit
  981.     endif
  982.  
  983.     if type([action]) = 'L'                      && get but no seek.
  984.       if .not. action
  985.         retcd = .t.
  986.         exit
  987.       endif
  988.     endif
  989.  
  990.     if type([keyfield]) = 'A'
  991.       fstring = ''
  992.       for i = 1 to len(keyfield)
  993.         fstring = fstring + string(keyfield[i])
  994.       next
  995.       fstring = trim(fstring)
  996.     else
  997.       fstring = trim(string(keyfield))
  998.     endif
  999.     if empty(fstring)
  1000.       retcd = .f.
  1001.       exit
  1002.     endif
  1003.     if type([fstring])$'CM'
  1004.       if type([action]) = 'C'
  1005.         sstring = action+'("' + fstring + '")'
  1006.         fstring = &sstring
  1007.       endif
  1008.     endif
  1009.     set softseek on
  1010.     seek fstring
  1011.     set softseek off
  1012.     if .not. eof()
  1013.       retcd = .t.
  1014.       exit
  1015.     else
  1016.       retcd = .f.
  1017.       center('Not found.',row2 - 1,col,col2 )
  1018.     endif
  1019.   enddo
  1020.   setcolor(kcolor)
  1021.   restscreen(row,col,row2+2,col2+2,scrn)
  1022. return retcd                                     && keyprompt
  1023.  
  1024. note Length of variable
  1025. *length
  1026. function length
  1027.   parameters var
  1028.   private i,j
  1029.  
  1030.   if type([var]) = 'C'
  1031.     return len(var)
  1032.   elseif type([var]) = 'M'
  1033.     i = var
  1034.     return len(i)
  1035.   elseif type([var]) = 'N'
  1036.     return len(str(var))
  1037.   elseif type([var]) = 'L'
  1038.     return 1
  1039.   elseif type([var]) = 'A'
  1040.     j = 0
  1041.     for i = 1 to len(var)
  1042.       if type('var[i]') <> 'U'
  1043.         j = max(j,length(var[i]))
  1044.       endif
  1045.     next
  1046.     return j
  1047.   elseif type([var]) = 'D'
  1048.     return 8
  1049.   else
  1050.     return 0
  1051.   endif
  1052.  
  1053.  
  1054.  
  1055.  
  1056. note Memo Edit
  1057. *memed
  1058. function memed
  1059.   parameters infld,r1,c1,r2,c2,xed,memtitle,udf
  1060.   * If udf is missing, display without pause
  1061.  
  1062.   private fld,l,c,nk,lk,curs,memoscreen,zoom
  1063.  
  1064.   #define memedmsg "│ F1: HELP │ Esc: Abort - Changes Lost   │ F9: Zoom                │ F10: Done │"
  1065.   #define memomsg  "│ F1: HELP │                             │ F9: Zoom            │ Esc/F10: Done │"
  1066.  
  1067.   zoom = .f.
  1068.  
  1069.   push_ckeys()                                 && save function keys
  1070.  
  1071.   l = 1                                          && cursor line
  1072.   c = 0                                          && cursor column
  1073.   if type([xed]) <> 'L'                          && Edit or show only.
  1074.     xed = .f.
  1075.     set key F2 to
  1076.   else
  1077.     set key F2 to memf2
  1078.   endif
  1079.   if type([r1]) <> 'N'
  1080.     r1 = 4
  1081.   endif
  1082.   if type([c1]) <> 'N'
  1083.     c1 = 2
  1084.   endif
  1085.   if type([r2]) <> 'N'
  1086.     r2 = 22
  1087.   endif
  1088.   if type([c2]) <> 'N'
  1089.     c2 = 78
  1090.   endif
  1091.   if type([memtitle]) <> 'C'
  1092.     memtitle = ''
  1093.   endif
  1094.   if type([udf]) <> 'C'
  1095.     udf = .f.
  1096.   endif
  1097.  
  1098.   save screen to memoscreen
  1099.  
  1100.  
  1101.   set key F9 to memf9
  1102.   set key F10 to memf10
  1103.  
  1104.   curs = savecurs()                              && save cursor position
  1105.   fld = infld                                    && save orginal data
  1106.  
  1107.   do while .t.
  1108.     if xed                                       && If editing,
  1109.       set key F1 to help_memo                    && Allow edit help
  1110.       set key ins to togcurs                     && and insert cursor toggle,
  1111.       cursor(if(readinsert(),'half','std'))
  1112.     else                                         && else
  1113.       set key F1 to                              && turn
  1114.       set key ins to                             && them
  1115.       set cursor off
  1116.     endif                                        && off.
  1117.     if .not. zoom
  1118.       center(memtitle,r1-1,c1-1,c2+1)
  1119.     * center(if(xed,memedmsg,memomsg),24)
  1120.       if xed
  1121.          center(memedmsg,24)
  1122.         fld = memoedit(fld,r1,c1,r2,c2,.t.,"memfunc",64,.f.,l,c)
  1123.       else
  1124.         memoedit(fld,r1,c1,r2,c2,.f.,udf)
  1125.         if type('udf') <> 'C'
  1126.           exit
  1127.         endif
  1128.       endif
  1129.     else
  1130.       @ 2,0 clear to 23,79
  1131.       @ 2,0,23,79 box edit_box
  1132.       hbar(3)
  1133.       center(memtitle,3,2,78)
  1134.       center(if(xed,memedmsg,memomsg),24)
  1135.       if xed
  1136.         fld = memoedit(fld,4,3,22,78,.t.,"memfunc",64,.f.,l,c)
  1137.       else
  1138.         memoedit(fld,4,3,22,78,.f.,udf)
  1139.         if type('udf') <> 'C'
  1140.           exit
  1141.         endif
  1142.       endif
  1143.     endif
  1144.     lk = lastkey()
  1145.     if lk = ctrl_w
  1146.       nk = chr(inkey())
  1147.       if nk = '|'                                && F9 was pressed
  1148.         zoom = (zoom = .f.)
  1149.         if ! zoom
  1150.           restore screen from memoscreen
  1151.         endif
  1152.       elseif nk = '2'                            && F2 was pressed
  1153.         xed = ! xed
  1154.       else                                       && F10 was pressed
  1155.         exit
  1156.       endif
  1157.     elseif lk = esc                              && Esc was pressed
  1158.       fld = infld
  1159.       restore screen from memoscreen           && restore the screen
  1160.       exit
  1161.     endif
  1162.   enddo
  1163.   pop_keys()                                     && restore function keys
  1164.   restcurs(curs)                                 && restore cursor
  1165.   release h_m_first
  1166. return fld 
  1167.  
  1168.  
  1169. function memfunc
  1170.   parameters status,line,col
  1171.   l = line
  1172.   c = col
  1173. return 0
  1174.  
  1175. procedure memf2
  1176.   keyboard chr(ctrl_w)+'2'
  1177. return
  1178.  
  1179. procedure memf9
  1180.   keyboard chr(ctrl_w)+'|'
  1181. return
  1182.  
  1183. procedure memf10
  1184.   keyboard chr(ctrl_w)
  1185. return
  1186.  
  1187. procedure togcurs
  1188.    readinsert(.not.readinsert())
  1189.    cursor(if(readinsert(),'half','std'))
  1190. return
  1191.  
  1192.  
  1193. #include memohelp.pre
  1194.  
  1195.  
  1196. ******************************* memed
  1197.  
  1198.  
  1199. note Pad
  1200. *pad
  1201. function pad
  1202. parameters string,length
  1203. if len(trim(string)) >= length
  1204.   return string
  1205. else
  1206.   return left(string + space(length),length)
  1207. endif
  1208.  
  1209. note Right Say
  1210. *rsay
  1211. function rsay
  1212.   parameters string,row,col
  1213.   private rcol
  1214.  
  1215.   if type([row]) <> 'N'
  1216.     row = row()
  1217.   endif
  1218.  
  1219.   if type([col]) <> 'N'
  1220.     col = 79
  1221.   endif
  1222.   rcol = col - len(string) + 1
  1223.   @ row,rcol say string
  1224. return rcol
  1225.  
  1226.  
  1227. note Save,Clear, and Box
  1228. *boxsave
  1229. function boxsave
  1230.   parameters row,col,row2,col2,boxcolor
  1231.   private scrn
  1232.   scrn = savescreen(row,col,row2+2,col2+2)
  1233.   if type([boxcolor]) = 'C'
  1234.     setcolor(boxcolor)
  1235.   endif
  1236.   @ row,col clear to row2,col2
  1237.   @ row,col to row2,col2 double
  1238.   shadow(row,col,row2,col2)
  1239. return scrn
  1240.  
  1241.  
  1242. note Search
  1243. *search
  1244. function search
  1245.   parameters code
  1246.   seek code
  1247. return(found())
  1248.  
  1249.  
  1250.  
  1251. note String Conversion
  1252. *string
  1253. function string
  1254.   parameters var,adl,atrim
  1255.   private i,j
  1256.  
  1257.   if type([atrim]) <> 'L'
  1258.     atrim = .t.
  1259.   endif
  1260.  
  1261.   if type([var]) = 'C'
  1262.     return var
  1263.   elseif type([var]) = 'M'
  1264.     i = var
  1265.     return i
  1266.   elseif type([var]) = 'N'
  1267.     return str(var)
  1268.   elseif type([var]) = 'L'
  1269.     return if(.t.,'T','F')
  1270.   elseif type([var]) = 'A'
  1271.     j = ''
  1272.     if type([adl]) = 'U'
  1273.       adl = ''
  1274.     else
  1275.       adl = string(adl)
  1276.     endif
  1277.     for i = 1 to len(var)
  1278.       if type('var[i]') <> 'U'
  1279.         if .not. empty(j) .and. .not. empty(var[i])
  1280.           j = j + adl
  1281.         endif
  1282.         if atrim
  1283.           j = j + trim(string(var[i]))
  1284.         else
  1285.           j = j + string(var[i])
  1286.         endif
  1287.       endif
  1288.     next
  1289.     return j
  1290.   elseif type([var]) = 'D'
  1291.     return dtoc(var)
  1292.   else
  1293.     return ''
  1294.   endif
  1295.  
  1296. note Vertical Bar (double)
  1297. *vbar2
  1298. function vbar2
  1299.   #ignore
  1300.   parameters col,trow,brow,p4,p5,p6,p7,p8,p9,p10
  1301.   private i
  1302.   if type([col]) <> 'N'
  1303.     col = col()
  1304.   endif
  1305.   if type([trow]) <> 'N'
  1306.     trow = 0 
  1307.   endif
  1308.   if type([brow]) <> 'N'
  1309.     brow = 24
  1310.   endif
  1311.   @ trow+1,col to brow-1,col double
  1312.   @ trow,col say chr(203)                        && ╦
  1313.   @ brow,col say chr(202)                        && ╩
  1314.   if pcount() > 3
  1315.     for i = 4 to pcount()
  1316.       x = 'p'+alltrim(str(i))
  1317.       @ &x,col say chr(206)                      && ╬
  1318.     next
  1319.   endif
  1320.   #xignore
  1321. return .t.
  1322.  
  1323.  
  1324. note Vertical Bar (single)
  1325. *vbar
  1326. function vbar
  1327.   #ignore
  1328.   parameters col,trow,brow,p4,p5,p6,p7,p8,p9,p10
  1329.   private i
  1330.   if type([col]) <> 'N'
  1331.     col = col()
  1332.   endif
  1333.   if type([trow]) <> 'N'
  1334.     trow = 0 
  1335.   endif
  1336.   if type([brow]) <> 'N'
  1337.     brow = 24
  1338.   endif
  1339.   @ trow+1,col to brow-1,col
  1340.   @ trow,col say chr(194)
  1341.   @ brow,col say chr(193)
  1342.   if pcount() > 3
  1343.     for i = 4 to pcount()
  1344.       x = 'p'+alltrim(str(i))
  1345.       @ &x,col say chr(197)
  1346.     next
  1347.   endif
  1348.   #xignore
  1349. return .t.
  1350.  
  1351. note Yes/No 
  1352. *yn 
  1353. function yn
  1354.   parameters string,row,col,default
  1355.   private yesno,row2,col2,scrn
  1356.    yesno = if(type([default]) <> 'C','N',if(upper(default)$'YN',upper(default),'N'))
  1357.  
  1358.   if type([string]) <> 'C'
  1359.     string = "Yes or No "
  1360.   endif
  1361.   string = string + " (Y/N) ?"
  1362.   if type([col]) <> 'N'
  1363.     col = (77 - len(string))/2
  1364.   endif
  1365.   if type([row]) <> 'N'
  1366.     row = 12
  1367.   endif
  1368.   col2 = min(len(string)+col+6,79)
  1369.   row2 = min(row + 4,24)
  1370.   scrn = boxsave(row,col,row2,col2)
  1371.   set cursor on
  1372.   @ row+2,col+2 say string get yesno picture "Y"
  1373.   read
  1374.   set cursor off
  1375.   restscreen(row,col,row2+2,col2+2,scrn)
  1376. return yesno
  1377.  
  1378. note Convert array to string with semicolons
  1379. *atoc
  1380. function atoc
  1381.   parameters arr
  1382.   * arr is array to convert
  1383.   * returns string with semicolons
  1384.   private i,string
  1385.   string = ''
  1386.   for i = 1 to len(arr)
  1387.     string = string + arr[i]
  1388.     if i < len(arr)
  1389.       string = string + ';'
  1390.     endif
  1391.   next
  1392.   i = -1
  1393.   do while .t.
  1394.     if substr(string,-1,1) = ';'
  1395.       string = left(string,len(string) - 1)
  1396.     else
  1397.       exit
  1398.     endif
  1399.   enddo
  1400. return string
  1401.  
  1402. note Convert character string with semicolons to array
  1403. *ctoa
  1404. function ctoa
  1405.   parameters string,arr
  1406.   * string is string with semicolons
  1407.   * arr is array to put strings in
  1408.   * returns false if number of semicolons is greater than array length
  1409.   *  or if number of semicolons is zero - still converts array if possible.
  1410.   private i,start,size,semicount
  1411.   store 0 to size,semicount
  1412.   start = 1
  1413.   for i = 1 to len(arr)
  1414.     size = atnext(';',string,i)
  1415.     if size > 0 
  1416.       semicount = semicount + 1
  1417.     else
  1418.       size = len(string) + 1
  1419.     endif
  1420.     arr[i] = substr(string,start,size - start)
  1421.     start = size + 1
  1422.   next
  1423. return .not. (semicount = 0 .or. semicount >= len(arr))
  1424.  
  1425. note Expand public array
  1426. *arrexpand
  1427. function arrexpand
  1428.   parameters array,bump
  1429.   private i,j
  1430.   if type([bump]) <> 'N'
  1431.     bump = 1
  1432.   endif
  1433.   i = len(array)
  1434.   private temparr[i]
  1435.   acopy(array,temparr)
  1436.   public array[i+bump]
  1437.   acopy(temparr,array)
  1438.   for j = i + 1 to i + bump
  1439.     array[j] = blank(array[1])
  1440.   next
  1441. return (i + bump)
  1442.  
  1443. note Display and pause
  1444. *showme
  1445. function showme
  1446.   parameter x1,x2,x3,x4,x5,x6,x7,x8,x9
  1447.   private i,y
  1448.   for i = 1 to pcount()
  1449.     y = 'x'+alltrim(str(i))
  1450.     ? '['
  1451.     ?? &y
  1452.     ?? ']'
  1453.   next
  1454.   ?
  1455.   inkey(0)
  1456. return .t.
  1457.  
  1458. note Modified read function
  1459. *xread
  1460. function xread
  1461.   set cursor on
  1462.   read
  1463.   set cursor off
  1464. return lastkey()
  1465.  
  1466.  
  1467.  
  1468.  
  1469. #include chkntx.pre
  1470. * eof
  1471.