home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / dbase / ccb_fix.arj / CCB_FEXT.COD next >
Encoding:
Text File  |  1991-06-09  |  61.1 KB  |  1,945 lines
  1. {
  2. // Module Name: FORM_EXT.COD
  3. // Description: This module produces PROCEDURES & FUNCTIONS
  4. //              used in form processing (for FORM.COD)
  5. //
  6. //----Modified 6/9/91 by Barry Fox, Fox Computer Consulting to allow
  7. //    help support generation to proceed if database name is different
  8. //    from form name.  Will prompt user for database name to check for
  9. //    existance of help dbf if no help dbf is found corresponding to 
  10. //    form name.
  11. //
  12. define screen_size()
  13.    // Test screen size if display > 2 screen is 43 lines
  14.    display = numset(_flgcolor)
  15.    if display > ega25 then
  16.        scrn_size = 39
  17.        max_pop_row = 36
  18.    else
  19.        scrn_size = 21
  20.        max_pop_row = 18
  21.    endif
  22.  
  23.    // Test to see if status was off before going into form designer
  24.    dB_status = numset(_flgstatus)
  25.    if scrn_size == 21 and !db_status then
  26.       scrn_size = 24
  27.       max_pop_row = 21
  28.    endif
  29.    if scrn_size == 39 and !db_status then // status is off
  30.       scrn_size = 42
  31.       max_pop_row = 39
  32.    endif
  33.    return;
  34. enddef
  35.  
  36. //--------------------------------------------------------------
  37. define display_type()
  38.     // Find out the display type we are working on
  39.     var temp;
  40.     case display of
  41.        mono:   temp = "MONO"
  42.        cga:    temp = "COLOR"
  43.        ega25:  temp = "EGA25"
  44.        mono43: temp = "MONO43"
  45.        ega43:  temp = "EGA43"
  46.      endcase
  47.      return temp;
  48. enddef
  49.  
  50. //--------------------------------------------------------------
  51. define getcolor(f_display,         // Color of the current field
  52.                 f_editable         // Field is SAY or GET
  53.                )
  54.  // Determines the color from f_display and f_editable (GET or SAY)
  55.  enum  Foreground  =   7,
  56.        Intensity   =   8,  // Color
  57.        Background  = 112,
  58.        MIntensity  = 256,
  59.        Reverse     = 512,  // Mono
  60.        Underline   =1024,
  61.        Blink       =2048,
  62.        default     =32768; // Screen set to default
  63.  
  64.  var forgrnd, enhanced, backgrnd, blnk, underln, revrse, use_colors, incolor;
  65.  incolor=""
  66.  
  67.  use_colors  = default & f_display
  68.  forgrnd  = Foreground & f_display
  69.  enhanced = (Intensity & f_display) || (MIntensity & f_display)
  70.  backgrnd = Background & f_display
  71.  blnk     = Blink  & f_display
  72.  underln  = Underline & f_display
  73.  revrse   = Reverse & f_display
  74.  
  75.  if not use_colors then // Use system colors, no colors set in designer
  76.  
  77.     if backgrnd then backgrnd = backgrnd/16 endif
  78.  
  79.     if (display != mono and display != mono43) then
  80.        case forgrnd of
  81.         0: incolor = "n"
  82.         1: incolor = "b"
  83.         2: incolor = "g"
  84.         3: incolor = "bg"
  85.         4: incolor = "r"
  86.         5: incolor = "rb"
  87.         6: incolor = "gr"
  88.         7: incolor = "w"
  89.        endcase
  90.     else
  91.        incolor = "w"
  92.     endif
  93.  
  94.     if revrse then
  95.        incolor = incolor + "i"
  96.     endif
  97.     if underln then
  98.        incolor = incolor + "u"
  99.     endif
  100.     if enhanced then
  101.        incolor = incolor + "+"
  102.     endif
  103.     if blnk then
  104.        incolor = incolor + "*"
  105.     endif
  106.  
  107.     incolor = incolor + "/"
  108.  
  109.     if (display != mono and display != mono43) then
  110.        case backgrnd of
  111.         0: incolor = incolor + "n"
  112.         1: incolor = incolor + "b"
  113.         2: incolor = incolor + "g"
  114.         3: incolor = incolor + "bg"
  115.         4: incolor = incolor + "r"
  116.         5: incolor = incolor + "rb"
  117.         6: incolor = incolor + "gr"
  118.         7: incolor = incolor + "w"
  119.        endcase
  120.     else
  121.        incolor = incolor + "n"
  122.     endif
  123.  
  124.     if f_editable and incolor then
  125.        incolor = incolor + "," + incolor
  126.     endif
  127.  
  128.  endif // use no colors
  129.  return alltrim(incolor);
  130. enddef
  131.  
  132. //--------------------------------------------------------------
  133. define outbox(mbox,            // Border type
  134.               mchar            // Special character of border
  135.              )
  136.    // Output the of Box border and character if any
  137.    var result;
  138.    case mbox of
  139.       0: result = " " // single
  140.       1: result = " DOUBLE "
  141.       2: result = " CHR("+mchar+") "
  142.    endcase
  143.    return result;
  144. enddef
  145.  
  146. //--------------------------------------------------------------
  147. define outcolor()
  148.   // Output the of color of the @ SAY GET or Box
  149.   var result;
  150.   result = "";
  151.   if len(color) > 0 then
  152.      if color_flg then
  153.         // If flag is set output a dBASE continuation ";"
  154.         result = ";" + crlf + space(3)
  155.      endif
  156.      result = result + "COLOR " + color + " "
  157.   endif
  158.   return result;
  159. enddef
  160.  
  161. //--------------------------------------------------------------
  162. define window_def(cur)                  // Pass in foreach cursor
  163.    // Build dBASE window command
  164.    var result;
  165.    result = "wndow" + wnd_cnt + " FROM " + Box_Coordinates(cur)
  166.    result = result + outbox(cur.BOX_TYPE, cur.BOX_SPECIAL_CHAR)
  167.    color = getcolor(cur.FLD_DISPLAY, cur.FLD_EDITABLE)
  168.    result = result + outcolor()
  169.    return result;
  170. enddef
  171.  
  172. //--------------------------------------------------------------
  173. define box_coordinates(cur)             // Pass in foreach cursor
  174.    // Build box coordinates for a dBASE window command
  175.    var result, temp_page, line_cnt;
  176.    temp_page = page_cnt;
  177.  
  178.    // Adjust box coordinates so that negative numbers are not generated
  179.    do while ( nul2zero(cur.BOX_TOP) - (scrn_size * temp_page) ) <= 1
  180.       temp_page = temp_page - 1
  181.    enddo
  182.    //-- Adjust "temp_page" for page 1 and 2
  183.    if page_cnt == 1 then
  184.       temp_page = 0
  185.    endif
  186.    if page_cnt == 2 then
  187.       temp_page = 1
  188.    endif
  189.    //-------------------------
  190.  
  191.    if !temp_page then
  192.       line_cnt = 0
  193.    else
  194.       line_cnt = (scrn_size * temp_page) + (1 * temp_page)
  195.    endif
  196.  
  197.    result = nul2zero(cur.BOX_TOP) - line_cnt +","
  198.    result = result + nul2zero(cur.BOX_LEFT) + " TO "
  199.    temp = nul2zero(cur.BOX_TOP) + cur.BOX_HEIGHT - line_cnt - 1
  200.    if temp > scrn_size then temp = scrn_size endif
  201.    result = result + temp + "," + (nul2zero(cur.BOX_LEFT) + cur.BOX_WIDTH - 1)
  202.    return result;
  203. enddef
  204.  
  205. //--------------------------------------------------------------
  206. define carry_flds()
  207.    // Build dBASE SET CARRY command
  208.    carry_len = carry_lent = 13
  209.    carry_first = 0
  210.    foreach FLD_ELEMENT flds
  211.       if FLD_CARRY then
  212.          carry_len = carry_len + len(FLD_FIELDNAME + ",")
  213.          carry_lent = carry_lent + len(FLD_FIELDNAME + ",")
  214.          if carry_lent > 1000 then
  215.             print(crlf + "SET CARRY TO ")
  216.             carry_len = carry_lent = 13
  217.          endif
  218.          if carry_len > 75 then 
  219.            print(";" + crlf + "  ")  
  220.            carry_len = 2 
  221.          endif
  222.          temp = cap_first(FLD_FIELDNAME)
  223.          if !carry_first then
  224.             print(temp)
  225.             carry_first = 1
  226.          else
  227.             print("," + temp)
  228.          endif
  229.       endif
  230.     next flds
  231.     print(" ADDITIVE");
  232.  return
  233. enddef
  234.  
  235. //--------------------------------------------------------------
  236. define picture_for_get(c)
  237.      if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  238. {       if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  239.  {//leave this space}\
  240. {    endif
  241.      if at("M", c.FLD_PICFUN) then
  242.         c.FLD_PIC_CHOICE}\
  243. {    else
  244.         c.FLD_TEMPLATE}\
  245. {    endif
  246.  return;
  247. enddef
  248.  
  249. //--------------------------------------------------------------
  250. define picture_for_say(c)
  251.      if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  252. {       if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  253.  {//leave this space}\
  254. {       endif
  255.      if !at("M", c.FLD_PICFUN) then
  256.         c.FLD_TEMPLATE}\
  257. {    endif
  258.  return;
  259. enddef
  260.  
  261. //--------------------------------------------------------------
  262. define ok_template(cur)                 // Pass in foreach cursor
  263.      if cur.FLD_TEMPLATE && !(chr(cur.FLD_VALUE_TYPE) == "D" ||
  264.                               chr(cur.FLD_VALUE_TYPE) == "M") then
  265.         return 1;
  266.      else
  267.         return 0;
  268.      endif
  269. enddef
  270. //--------------------------------------------------------------
  271. define ok_coordinates(cur,              // Current cursor
  272.                       xtra_width,       // Additional width to check ie, shadow
  273.                       want_message,     // Display message flag 0:No 1:Yes
  274.                       message)          // Message to display to user
  275.      // Check to see if coordinates of popup or shadow will fit on screen
  276.      // based on the dimensions of the current field
  277.      if nul2zero(cur.COL_POSITN) + len(cur.FLD_TEMPLATE) + xtra_width > screen_width then
  278.         if want_message then
  279.            beep(2)                      // UDF in builtin.def
  280.            cls()
  281.            say_center(10,"Error on Field: " + cur.FLD_FIELDNAME)
  282.            say_center(12, message)
  283.            pause(any_key)
  284.         endif
  285.         return 0;
  286.      else
  287.         return 1;
  288.      endif
  289. enddef
  290.  
  291. //--------------------------------------------------------------
  292. define make_program(ext)
  293.    // Attempt to create program (fmt) file.
  294.    ext = upper( ext)
  295.    default_drv = strset(_defdrive)  // grab default drive from dBASE
  296.    fmt_name = FRAME_PATH + NAME     // Put path on to object name
  297.    if not fileok(fmt_name) then
  298.       if not default_drv then
  299.          fmt_name = NAME
  300.       else
  301.          fmt_name = default_drv + ":" + NAME
  302.       endif
  303.    endif
  304.    fmt_name = upper(fmt_name)
  305.    if not create(fmt_name + ext) then
  306.         pause(fileroot(fmt_name) + ext + read_only + any_key)
  307.         return 0;
  308.      endif
  309.    return 1;
  310. enddef
  311.  
  312. //--------------------------------------------------------------
  313. define make_udf()
  314.    // Attempt to create dBASE procedure (prg) file.
  315.    var udf_root_file_name;
  316.    udf_root_file_name =  frame_path + "u_" + rtrim(substr(name,1,6))
  317.    if not create( udf_root_file_name + ".PRG") then
  318.       pause(udf_root_file_name + ".PRG" + read_only + any_key)
  319.       return 0;
  320.    endif
  321.    // Force dBASE to recompile the .prg
  322.    fileerase(udf_root_file_name + ".DBO")
  323.    udf_file = 1 // Global flag to determine if UDF file was created
  324.    return 1;
  325. enddef
  326.  
  327. //--------------------------------------------------------------
  328. define udf_header()
  329.     // Print Header in UDF program
  330.     print("*"+replicate("-",78)+crlf);}
  331. *-- Name....: {frame_path}u_{rtrim(substr(name,1,6))}.PRG
  332. *-- Date....: {ltrim(SUBSTR(date(),1,8))}
  333. *-- Version.: dBASE IV, Procedures for Format (.fmt) v{Frame_ver}.1
  334. *-- Notes...: Procedure file for VALID POPUPs and/or Context Sensitive Help
  335. *-- ........: for {filename(fmt_name)}FMT
  336. {print("*"+replicate("-",78)+crlf);
  337. enddef
  338.  
  339. //--------------------------------------------------------------
  340. define make_pop_code()
  341.      var lookup_dbf,  // store get_file(FLD_OK_COND) for faster processing
  342.          is_format,   // is there a format file
  343.          temp_name,   // store get_popname(FLD_OK_COND) for faster processing
  344.          ;
  345.          //              temp_key;    // store KEY field
  346.  
  347. //   Create the Procedure File for POPUP's if required
  348.      if is_popup then
  349. //          if !at("FORMBROW", upper(getenv("dtl_form"))) then
  350.              if !make_udf() then
  351.                   return 0;
  352.               endif
  353.             udf_header()
  354. //          endif
  355.           if workarea_cnt <= max_workareas then
  356. }
  357. PROCEDURE S_{lower(substr(name,1,7))}{tabto(40)}&& Open Lookup files for faster processing
  358. {           foreach FLD_ELEMENT flds
  359.                  if popup_or_browse(flds) then
  360.                     lookup_dbf = get_file(FLD_OK_COND)
  361.                     if not at(lookup_dbf, workarea_dbfs) then
  362.                        workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  363. }
  364.   USE {lookup_dbf} ORDER {get_key(FLD_OK_COND)} IN SELECT() \
  365. {                      if (upper(lookup_dbf) == FLD_FILENAME) then}
  366. AGAIN ALIAS {"A"+substr(lookup_dbf,1,7)}
  367. {                      else}
  368.  {//leave this space}
  369. {                      endif
  370.                     endif
  371.                  endif
  372.             next flds;
  373. }
  374. RETURN
  375. *-- EOP: S_{lower(substr(name,1,7))}
  376.  
  377. PROCEDURE C_{lower(substr(name,1,7))}{tabto(40)}&& Close Lookup files
  378. {           workarea_dbfs = ""
  379.             foreach FLD_ELEMENT flds
  380.                  if popup_or_browse(flds) then
  381.                     lookup_dbf = get_file(FLD_OK_COND);
  382.                     if not at(lookup_dbf, workarea_dbfs) then
  383.                        workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  384. }
  385.   USE IN ALIAS("{ upper(lookup_dbf) == FLD_FILENAME ? "A"+substr(lookup_dbf,1,7) : lookup_dbf }")
  386. {                   endif
  387.                  endif
  388.             next flds;
  389.           endif
  390. }
  391. RETURN
  392. *-- EOP: C_{lower(substr(name,1,7))}
  393.  
  394. FUNCTION Empty                       && Determine if the passed argument is NULL
  395. {lmarg(offset)}
  396. PARAMETER x
  397. PRIVATE retval, lc_type
  398. lc_type = TYPE("x")
  399. DO CASE
  400.   CASE lc_type = "C"
  401.     retval = (LEN(TRIM(x))=0)
  402.   CASE lc_type$"NF"
  403.     retval = (x=0)
  404.   CASE lc_type = "D"
  405.     retval = (" "$DTOC(x))
  406.   OTHERWISE lc_type = "U"
  407.     retval = .T.
  408. ENDCASE
  409. {lmarg(0)}
  410. RETURN (retval)
  411. *-- EOP: _Empty
  412.  
  413. {print("*"+replicate("-",78)+crlf);}
  414. PROCEDURE _DbfEmpty
  415.    *-- Error box if Lookup .dbf is empty
  416.    *-- Save the screen and setup window
  417.    PRIVATE ALL LIKE l?_*
  418.    DEFINE WINDOW u_error FROM 5,15 TO 11,55
  419.    SAVE SCREEN TO u_error
  420.    DO _Shadowg WITH 5,15,11,55
  421.  
  422.    *-- Activate the window and put up error message
  423.    ACTIVATE WINDOW u_error
  424.    lc_fpath = SET("fullpath")
  425.    SET FULLPATH OFF
  426.    @ 1,2 SAY "Lookup table: " + SUBSTR( DBF(),3) + " is empty!"
  427.    @ 2,2 SAY "{any_key}"
  428.    ln_errorky = INKEY(10)
  429.  
  430.    *-- Restore the screen and clean up
  431.    SET FULLPATH &lc_fpath.
  432.    RELEASE WINDOW u_error
  433.    RESTORE SCREEN FROM u_error
  434.    RELEASE SCREEN u_error
  435. RETURN
  436. *-- EOP: _DbfEmpty
  437.  
  438. {
  439.           line_cnt = 0
  440.           page_cnt = 1
  441.  
  442.           foreach FLD_ELEMENT flds
  443.  
  444.                at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0;
  445.  
  446.                new_page(flds)
  447.                if popup_or_browse(flds) then
  448.                     trow_positn = nul2zero(ROW_POSITN) - line_cnt
  449.                     tcol_positn = nul2zero(COL_POSITN)
  450.                     color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  451.  
  452.                     if at_pop and !ok_coordinates(flds, 2, 0, "") then loop endif
  453.  
  454.                     print("*"+replicate("-",78)+crlf);
  455. }
  456. FUNCTION {get_udfname(FLD_FIELDNAME)}
  457. {lmarg(offset)}
  458. PARAMETER fld_name
  459. PRIVATE ALL LIKE l?_*
  460. PRIVATE fld_name, rtn_fld
  461.  
  462. ll_return = .T.                      && Declare return variable for function
  463. ln_row = ROW()                       && Current Row of Get
  464. ln_col = COL()                       && Current Column of Get
  465. rtn_fld = fld_name                   && Current Value of Get
  466.  
  467. {                   if !is_required(FLD_OK_COND) then}
  468. IF EMPTY(fld_name)                   && Not a required field
  469.   RETURN (.T.)                       && if null field
  470. ENDIF
  471.  
  472. {                    endif
  473.                      if is_help then}
  474.  
  475. ON KEY LABEL {on_key_help}
  476. {                    endif
  477.                      if is_recalc then}
  478. ON KEY LABEL {on_key_recalc}
  479. {                    endif
  480.                      if is_zoom then}
  481. ON KEY LABEL {on_key_zoom}
  482. {                    endif}
  483.  
  484. lc_alias = ALIAS()                   && Grab current workarea
  485. //--------------------------------------------------------------------------
  486. // kjn New design for Edit/Browse that will eliminate the @ GET code
  487. // Will allow this code to go away
  488. //--------------------------------------------------------------------------
  489.  
  490. IF ln_row = {row_positn} .AND. (ln_col >= {col_positn} .AND. ln_col <= {col_positn+FLD_LENGTH+6} )
  491.    ll_edit = .T.
  492. ELSE
  493.    ll_edit = .F.
  494. ENDIF
  495.  
  496. {                   lookup_dbf = get_file(FLD_OK_COND);
  497.                     temp_key = alltrim(get_key(FLD_OK_COND));
  498.  
  499.                     if workarea_cnt <= max_workareas then
  500. }
  501. SELECT ("{ upper(lookup_dbf) == FLD_FILENAME ? "A"+substr(lookup_dbf,1,7) : 
  502.                                                lookup_dbf }")
  503. {                   else}
  504. SELECT SELECT()
  505. IF FILE("{lookup_dbf}.dbf")
  506.    USE {lookup_dbf} ORDER {temp_key} \
  507. {                     if (upper(lookup_dbf) == FLD_FILENAME) then}
  508. AGAIN
  509. {                     else}
  510.  {//leave this space}
  511. {                     endif}
  512. ELSE
  513.    SET MESSAGE TO "{lookup_dbf}.dbf {use_err}  {any_key}"
  514.    ll_wait = INKEY(0)
  515.    SET MESSAGE TO
  516.    RETURN .F.
  517. ENDIF
  518. {                   endif  // workarea_cnt}
  519.  
  520. lc_exact = SET("EXACT")              && Store value of EXACT
  521. SET EXACT ON
  522. {                   if !at_pop then}
  523. lc_near =  SET("NEAR")               && Store value of NEAR
  524. SET NEAR ON                          && Do "soft" seek into "BROWSE"
  525.  
  526. {                   endif
  527.                     if chr(FLD_VALUE_TYPE) == "C" then}
  528. fld_name = IIF( EMPTY( TRIM( fld_name)), fld_name, TRIM( fld_name))
  529. {                   endif}
  530. SEEK fld_name
  531.  
  532. SET EXACT &lc_exact.                 && Restore SET EXACT to org. value
  533. {                   if !at_pop then}
  534. SET NEAR  &lc_near.                  && Restore SET NEAR  to org. value
  535. {                   endif}
  536.  
  537. IF .NOT. FOUND()
  538.  
  539. {                   temp_name = get_popname(FLD_OK_COND);
  540.  
  541.                     if at_pop then  // Gen for Popup lookup}
  542.    DEFINE POPUP {temp_name} FROM \
  543. {                      if trow_positn < max_pop_row then
  544.                           trow_positn + 1},{tcol_positn} ;
  545.     TO {scrn_size-1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  546. {                      else
  547.                            trow_positn - 11},{tcol_positn} ;
  548.     TO {trow_positn - 1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  549. {                      endif}
  550.     PROMPT FIELD {get_field(FLD_OK_COND)} ;
  551.     MESSAGE {select_msg1}
  552.  
  553.    ON SELECTION POPUP {temp_name} DEACTIVATE POPUP
  554.  
  555. {                      if chr(FLD_VALUE_TYPE) == "C" then}
  556.    KEYBOARD TRIM( fld_name ) CLEAR
  557.  
  558. {                      endif
  559.                     else
  560.                        // Gen for BROWSE lookup
  561.                        if (is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  562.                        // If updateable and fields declared then check for no records
  563. }
  564. //  Currently BLOWS dbase UP kjn
  565. //
  566. //   IF RECCOUNT() = 0
  567. //      APPEND BLANK
  568. //      REPLACE {cap_first(FLD_FIELDNAME)} WITH \
  569. //{            cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)}
  570. //      KEYBOARD( CHR( kn_Tab)) CLEAR
  571. //   ENDIF
  572. //{                      else}
  573.    IF RECCOUNT() = 0
  574.       DO _DbfEmpty
  575.       ll_return = .F.
  576.    ENDIF
  577.  
  578.    IF ll_return
  579.  
  580. {                         lmarg(offset*2)
  581.                        endif}
  582.    DEFINE WINDOW {temp_name} FROM \
  583. {                      if is_window(FLD_OK_COND) then
  584.                           get_browse_window(flds)
  585.                        else
  586.                           print("14,0 TO 20,79")
  587.                        endif
  588. }
  589.  
  590. {                   endif}
  591.    SAVE SCREEN TO {temp_name}
  592.  
  593. {                   if is_shadow(FLD_OK_COND) then
  594.                        if at_pop and ok_coordinates( flds, 4, 1, bad_shadow ) then
  595. }
  596.    DO _Shadowg WITH {get_pop_shadow(FLD_TEMPLATE);}
  597. {                      endif
  598.                        if !at_pop then}
  599.    DO _Shadowg WITH \
  600. {                         if is_window(FLD_OK_COND) then
  601.                              get_browse_shadow(FLD_OK_COND)
  602.                           else
  603.                              print("14,0,20,77")
  604.                           endif
  605.                        endif
  606.                     endif
  607.                     if at_pop then}
  608.    ACTIVATE POPUP {temp_name}
  609.  
  610.    rtn_fld = PROMPT()               && Get user choice from Picklist
  611.  
  612.    RELEASE POPUP {temp_name}
  613. {                   else}
  614.  
  615.    lc_message = {select_msg1} +;
  616.                 {select_msg2}
  617.  
  618.    lc_message = IIF("500" $ VERSION(1), ;
  619.                  LEFT( lc_message, LEN( lc_message) - 17) , lc_message)
  620.    SET MESSAGE TO lc_message
  621.  
  622.    ON KEY LABEL Ctrl-M KEYBOARD( CHR( kn_CtrlEnd)) CLEAR   && Same as Enter send Ctrl-W
  623.  
  624. {                   is_format = is_format_file(flds, FLD_OK_COND);
  625.                     if is_format then}
  626.    IF FILE("{fileroot( get_format_file( FLD_OK_COND)) + ".FMT"}")
  627.       SET FORMAT TO {fileroot( get_format_file(FLD_OK_COND))}
  628.    ENDIF
  629.  
  630. {                   endif}
  631.    IF .NOT. "500" $ VERSION(1)
  632.       ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
  633.    ENDIF
  634.  
  635.    BROWSE WINDOW {temp_name} NOMENU COMPRESS NOFOLLOW NODELETE LOCK 1 \
  636. {                   if ( !is_update(FLD_OK_COND) or
  637.                          !is_fields(FLD_OK_COND) or
  638.                          ( upper(lookup_dbf) == FLD_FILENAME )
  639.                        ) then}
  640. ;
  641.       NOAPPEND NOEDIT \
  642. {                   endif
  643.                     if is_format then}
  644. ;
  645.       FORMAT \
  646. {                   endif
  647.                     if is_fields(FLD_OK_COND) then}
  648. ;
  649.       FIELDS {get_browse_fields_list(flds)} \
  650. //                                             outputs correct line spacing
  651. {                   endif}
  652.  
  653.  
  654. //  Currently BLOWS dbase UP kjn
  655. //{                   if is_update(FLD_OK_COND) then}
  656. //   IF EMPTY({cap_first(get_field(FLD_OK_COND))}) .AND. RECCOUNT() = 1
  657. //      lc_safety = SET("SAFETY")
  658. //      SET SAFETY OFF
  659. //      ZAP
  660. //      SET SAFETY &lc_safety.
  661. //   ENDIF
  662. //
  663. //{                   endif}
  664. {                   if is_format then}
  665.    SET FORMAT TO
  666. {                   endif}
  667.    ON KEY LABEL {on_key_move}
  668.    ON KEY LABEL Ctrl-M
  669.    SET MESSAGE TO
  670.  
  671.    RELEASE WINDOW {temp_name}
  672. {                   endif}
  673.  
  674.    RESTORE SCREEN FROM {temp_name}
  675.  
  676. {//  for code that blows up above kjn
  677.  //                   if !(is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  678.                        // Need ENDIF for IF ll_return above
  679.  
  680.                       if (is_update(FLD_OK_COND) and is_fields(FLD_OK_COND)) then
  681.                       // for now gen endif for this, kjn.  if append works
  682.                       // delete this if and uncomment out the one right above
  683.                        lmarg(offset)
  684. }
  685.    ENDIF
  686. {                   endif}
  687.  
  688.    IF LASTKEY() <> kn_esc
  689. {                   if !at_pop then}
  690.      rtn_fld = {cap_first(get_field(FLD_OK_COND))}
  691. {                   endif}
  692. {                   if is_required(FLD_OK_COND) then}
  693.  
  694.      IF EMPTY(rtn_fld)             && Is a required field, so return .F.
  695.         ll_return = .F.
  696.      ELSE
  697. {                      lmarg(offset * 2)
  698.                     endif}
  699.  
  700. //--------------------------------------------------------------------------
  701. // kjn New design for Edit/Browse that will eliminate the @ GET code
  702. // Will allow this code to go away
  703. //--------------------------------------------------------------------------
  704.      IF ll_edit
  705.         @ {trow_positn},{tcol_positn} GET rtn_fld \
  706. {        if Ok_Template(flds) then}
  707. PICTURE "{picture_for_get(flds);}" \
  708. {           outcolor()}
  709. {        endif}
  710.  
  711.      ENDIF
  712. //--------------------------------------------------------------------------
  713.  
  714.      REPLACE {cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)} WITH \
  715. {                   if chr(FLD_VALUE_TYPE) == "C" or
  716.                        at("BROWSE", upper(ltrim(FLD_OK_COND))) == "2" then}
  717. rtn_fld
  718. {                   else}
  719. VAL(rtn_fld)
  720. {                   endif}
  721.  
  722.      ll_return = .T.
  723. {                   if is_required(FLD_OK_COND) then
  724.                        lmarg(offset)}
  725.      ENDIF
  726. {                   endif}
  727.    ELSE
  728.      ll_return = .F.
  729. {
  730.                     if !is_required(FLD_OK_COND) then
  731. }
  732.  
  733.      IF EMPTY(fld_name)             && Not a required field, so return .t.
  734.         ll_return = .T.
  735.      ENDIF
  736.  
  737. {                   endif}
  738.    ENDIF
  739.  
  740. ELSE
  741.   ll_return = .T.
  742. ENDIF
  743. {if is_replace(FLD_OK_COND) then}
  744.  
  745. IF ll_return
  746.    DO U_{lower(substr(FLD_FIELDNAME,1,7))} WITH ll_edit, \
  747. {                   if chr(FLD_VALUE_TYPE) == "C" or
  748.                        at("BROWSE", upper(ltrim(FLD_OK_COND))) == "2" then}
  749. rtn_fld
  750. {                   else}
  751. VAL(rtn_fld)
  752. {                   endif}
  753. ENDIF
  754. {endif}
  755.  
  756. {if workarea_cnt > max_workareas then}
  757. USE
  758.  
  759. {endif}
  760. SELECT (lc_alias)                    && Go back to the edit file
  761.  
  762. {if is_help then}
  763. ON KEY LABEL {on_key_help} \
  764. DO {"H_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Help code
  765. {endif
  766.  if is_recalc then}
  767. ON KEY LABEL {on_key_recalc} \
  768. DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Recalc code
  769. {endif
  770.  if is_zoom then}
  771. ON KEY LABEL {on_key_zoom} \
  772. DO {"Z_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD() && Call Zoom code
  773. {endif
  774.  lmarg(0)}
  775. RETURN (ll_return)
  776. *-- EOP: {get_udfname(FLD_FIELDNAME)}
  777.  
  778. {              endif
  779.           next flds
  780.       endif   // there were POPUP VALID clauses
  781.  
  782.      return;
  783. // eof - make_pop_code()
  784. enddef
  785.  
  786. //--------------------------------------------------------------
  787. define make_shadow_proc()
  788.      // Make the dBASE code for shadowing
  789.      print("*"+replicate("-",78)+crlf);
  790. }
  791. PROCEDURE _Shadowg                      && displays shadow that grows
  792. {    lmarg(offset)}
  793. PARAMETER x1,y1,x2,y2
  794. PRIVATE   x1,y1,x2,y2
  795.  
  796. x0 = x2+1
  797. y0 = y2+2
  798. dx = 1
  799. dy = (y2-y1) / (x2-x1)
  800. DO WHILE x0 <> x1 .OR. y0 <> y1+2
  801.   @ x0,y0 FILL TO x2+1,y2+2 COLOR n+/n
  802.   x0 = IIF(x0<>x1,x0 - dx,x0)
  803.   y0 = IIF(y0<>y1+2,y0 - dy,y0)
  804.   y0 = IIF(y0<y1+2,y1+2,y0)
  805. ENDDO
  806. {    lmarg(0)}
  807. RETURN
  808. *-- EOP: _Shadowg
  809.  
  810. {print("*"+replicate("-",78)+crlf);}
  811. PROCEDURE _dbtrap                             && error routine for SET("dbtrap")
  812. {    var wcol1, wcol2, error_msg_length;
  813.       error_msg_length = len( dbtrap_err)
  814.       wcol1 = (screen_width/2) - ( error_msg_length/2) - 2
  815.       wcol2 = (screen_width/2) + ( error_msg_length/2) + 2
  816.      lmarg(offset);
  817. }
  818. SET CURSOR OFF
  819. PRIVATE ALL LIKE l?_*
  820. SAVE SCREEN TO _dbtrap
  821. DO _Shadowg WITH 10, {wcol1}, 15, {wcol2}
  822. DEFINE WINDOW _dbtrap FROM 10,{wcol1} TO 15,{wcol2} DOUBLE
  823. ACTIVATE WINDOW _dbtrap
  824. lc_error = "{dbtrap_err}"
  825. lc_error2 = "{any_key}"
  826. @ 1, CENTER( lc_error,  {wcol2 - wcol1}) SAY lc_error
  827. @ 2, CENTER( lc_error2, {wcol2 - wcol1}) SAY lc_error2
  828. lc_wait = INKEY(10)
  829. RELEASE WINDOW _dbtrap
  830. RESTORE SCREEN FROM _dbtrap
  831. RELEASE SCREEN _dbtrap
  832. SET CURSOR ON
  833. {    lmarg(0)}
  834. RETURN
  835. *-- EOP: _dbtrap
  836. {    return;
  837. enddef // make_shadow_proc()
  838.  
  839. //--------------------------------------------------------------
  840. define make_help_code()
  841.      //------------------------------------
  842.      // Make procedures for the help system
  843.      // called from form.gen
  844.      //------------------------------------
  845.       if is_help then
  846.          // If the udf file has not already been created, make it.
  847.         if !udf_file then
  848.            if !make_udf() then
  849.               return 0;
  850.            endif
  851.            // Put up the UDF header
  852.            udf_header()
  853.         endif
  854.         // Make procedures for the help system
  855.         make_help()
  856.       endif
  857. return;
  858. enddef
  859.  
  860. //--------------------------------------------------------------
  861. define make_help()
  862.    // Make the dBASE code for help
  863.    var help_name;
  864.    help_name = "H_" + lower(rtrim(substr(name,1,6)))
  865.    print("*"+replicate("-",78)+crlf);
  866. }
  867.  
  868. PROCEDURE {help_name}
  869. {    lmarg(offset)}
  870. *-- Activates the HELP window
  871. PARAMETER lc_var
  872. PRIVATE ALL LIKE l?_*
  873. IF .NOT. FILE("{fileroot(hlp_name)}.dbf")
  874.    *-- Help file has been deleted or can't be found
  875.    RETURN
  876. ENDIF
  877.  
  878. SET CURSOR OFF
  879. ON KEY LABEL {on_key_help}
  880.  
  881. *-- Select workarea and open Help dbf
  882. lc_area = ALIAS()
  883. SELECT SELECT()
  884. USE {fileroot(hlp_name)} ORDER fld_name NOUPDATE   && Open HELP .dbf
  885.  
  886. lc_exact = SET("EXACT")                && Store value of EXACT
  887. SET EXACT ON
  888. SEEK lc_var
  889. SET EXACT &lc_exact.
  890.  
  891. IF FOUND()                             && If found show Help
  892.   ln_t = 5
  893.   ln_l = 6
  894.   ln_b = 15
  895.   ln_r = 74
  896.   DEFINE WINDOW {lower(help_name)} FROM ln_t+1, ln_l+2 TO ln_b-1, ln_r-2 NONE
  897.   ON ERROR lc_error = error()
  898.   SAVE SCREEN TO {lower(help_name)}
  899.  
  900.   *-- Make Help Box
  901.   DO _Shadowg WITH ln_t, ln_l, ln_b, ln_r
  902.   @ ln_t+1, ln_l+1 CLEAR TO ln_b-1, ln_r-1
  903.   @ ln_t, ln_l TO ln_b, ln_r DOUBLE
  904.  
  905.   ln_memline = SET("MEMO")
  906.   SET MEMOWIDTH TO 65
  907.   IF MEMLINES(fld_help) > 9
  908.     @ ln_t+1,ln_r SAY CHR(24)
  909.     @ ln_b-1,ln_r SAY CHR(25)
  910.     SET CURSOR ON
  911.   ENDIF
  912.   lc_string = CHR(185)+ [ Help for ] + TRIM(fld_headng) +[ ] + CHR(204)
  913.   lc_message = IIF( MEMLINES(fld_help) > 9 , ;
  914.                     "{help_msg1}" , ;
  915.                     "" ;
  916. //                    "{help_msg1 + help_msg2}" , ;
  917. //                    "{help_msg2}" ;
  918.                   )
  919.  
  920.   @ ln_t,CENTER(lc_string,80) SAY lc_string
  921.   @ 0,0 GET fld_help OPEN WINDOW {lower(help_name)} MESSAGE lc_message
  922. //  ON KEY LABEL {on_key_toggle} DO _Toggle
  923. //  ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
  924.   READ
  925.   SET MEMOWIDTH TO ln_memline
  926.   ON ERROR
  927. //  ON KEY LABEL {on_key_toggle}
  928. //  ON KEY LABEL {on_key_move}
  929.   RELEASE WINDOW {lower(help_name)}
  930.   RESTORE SCREEN FROM {lower(help_name)}
  931.   RELEASE SCREEN {lower(help_name)}
  932. ENDIF
  933. SET MESSAGE TO
  934. SET CURSOR ON
  935. USE                                              && Close help file
  936. SELECT (lc_area)                                 && Back to edit work area
  937. ON KEY LABEL {on_key_help} DO {help_name} WITH VARREAD()
  938. {    lmarg(0)}
  939. RETURN
  940. *-- EOP: {help_name}
  941.  
  942. //{    print("*"+replicate("-",78)+crlf);}
  943. //PROCEDURE _Toggle
  944. //{    lmarg(offset)}
  945. //PRIVATE ln_wait
  946. //*-- Toggles the Help message back to the original screen
  947. //SAVE SCREEN TO Toggle
  948. //RESTORE SCREEN FROM {lower(help_name)}
  949. //{    if (scrn_size == 24 or scrn_size == 42) then}
  950. //@ {scrn_size}, 0
  951. //@ {scrn_size}, CENTER("{any_key}", {screen_width}) SAY "{any_key}"
  952. //{    else}
  953. //SET MESSAGE TO "{any_key}"
  954. //{    endif}
  955. //ln_wait = INKEY(15)
  956. //RESTORE SCREEN FROM Toggle
  957. //RELEASE SCREEN Toggle
  958. //SET MESSAGE TO lc_message
  959. //{    lmarg(0)}
  960. //RETURN
  961. //*-- EOP: _Toggle
  962. //
  963. {return;
  964. enddef
  965.  
  966. //--------------------------------------------------------------
  967. define make_other_udfs()
  968.     // Make other UDF's used durning form processing
  969.     print(crlf + "*"+replicate("-",78)+crlf);
  970. }
  971. PROCEDURE _Cut
  972. {    lmarg(offset)}
  973. *-- Cut data from a field
  974. PRIVATE ALL LIKE l?_*
  975.  
  976. lc_field = VARREAD()
  977. lc_type = TYPE( lc_field)
  978. SAVE SCREEN TO _cut
  979.  
  980. DO CASE
  981. CASE lc_type = "C"
  982.     gc_cut = TRIM( &lc_field.)
  983. CASE lc_type $ "NF"
  984.     ln_cnt = 0
  985.     ln_number = &lc_field.
  986.     DO WHILE _numdec( ln_number)
  987.        ln_number = ln_number * 10
  988.        ln_cnt = ln_cnt + 1
  989.     ENDDO
  990.     gc_cut = LTRIM( STR( &lc_field., 14, ln_cnt))
  991. CASE lc_type = "D"
  992.     gc_cut = DTOC( &lc_field.)
  993. CASE lc_type = "L"
  994.     gc_cut = IIF( &lc_field., "Y", "F")
  995. CASE lc_type = "M"
  996.     gc_cut = SUBSTR( &lc_field., 1, 254)
  997.     ln_len = LEN( TRIM( gc_cut))
  998.     ln_cnt = 1
  999.  
  1000.     DO WHILE ln_cnt <= ln_len
  1001.        *-- Get rid of MODI COMM's soft carriage returns characters
  1002.        IF ASC( SUBSTR( gc_cut, ln_cnt, 1)) = 141 .OR.;
  1003.           ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  10 .OR.;
  1004.           ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  13
  1005.  
  1006.           IF ASC( SUBSTR( gc_cut, ln_cnt, 1)) =  13
  1007.              gc_cut = STUFF( gc_cut, ln_cnt, 1, " ")
  1008.           ELSE
  1009.              gc_cut = STUFF( gc_cut, ln_cnt, 1, "")
  1010.           ENDIF
  1011.  
  1012.           ln_len = LEN( TRIM( gc_cut))             && Length of string can change
  1013.           LOOP
  1014.        ENDIF
  1015.        ln_cnt = ln_cnt + 1
  1016.       ENDDO
  1017. ENDCASE
  1018.  
  1019. lc_message = SUBSTR( gc_cut, 1, {(screen_width - 1) - len(paste_msg1)}) + "{paste_msg1}"
  1020. {    if (scrn_size == 24 or scrn_size == 42) then}
  1021. @ {scrn_size}, CENTER(lc_message, {screen_width}) SAY lc_message
  1022. {    else}
  1023. SET MESSAGE TO lc_message
  1024. {    endif}
  1025. ln_key = INKEY(2.5)
  1026. gc_cut = gc_cut + SPACE( 254 - LEN( gc_cut))
  1027. SET MESSAGE TO
  1028. RESTORE SCREEN FROM _cut
  1029. RELEASE SCREEN _cut
  1030. {    lmarg(0)}
  1031. RETURN
  1032.  
  1033. {    print("*"+replicate("-",78)+crlf);}
  1034. PROCEDURE _Paste
  1035. {    lmarg(offset)}
  1036. *-- Cut data to a field
  1037. PRIVATE ALL LIKE l?_*
  1038.  
  1039. lc_field = VARREAD()                               && Grab field we left from
  1040. lc_type = TYPE( lc_field)                          && Grab the data type
  1041. lc_cut = TRIM( gc_cut)                             && Trim blanks from cut data
  1042.  
  1043. IF lc_type = "D"
  1044.     *-- Remove "/" from character data so that KEYBOARD will work on a
  1045.     *-- date field
  1046. //  KJN "/" -> set("sepa")
  1047.     lc_cut = STUFF(lc_cut, AT("/", lc_cut), 1, "") && Get rid of first  "/"
  1048.     lc_cut = STUFF(lc_cut, AT("/", lc_cut), 1, "") && Get rid of second "/"
  1049. ENDIF
  1050. *-- Keyboard cut data into the field
  1051. DO CASE
  1052.    CASE lc_type $ "NFD"
  1053.       *-- Start at the beginning of the field and clear it.
  1054.       KEYBOARD ( CHR(kn_home) + CHR(kn_CtrlY) + lc_cut) CLEAR
  1055.    CASE lc_type <> "M"
  1056.       *-- Paste at the location of the cursor
  1057.       KEYBOARD (lc_cut) CLEAR
  1058.    OTHERWISE
  1059.       IF LEN( &lc_field.) > 0
  1060.          *-- Pad space to offset "scrap" from end of memo
  1061.          lc_cut = " " + lc_cut
  1062.       ENDIF
  1063.       REPLACE &lc_field. WITH lc_cut ADDITIVE         && Replace into memo field
  1064.       ln_keyboard = CHR(kn_ctrlhme) + CHR(kn_ctrlpdn) + ;
  1065.                     CHR(kn_space) + CHR(kn_bakspce)   && Makes EDIT think data has changed
  1066.       KEYBOARD (ln_keyboard) CLEAR                    && Move to bottom of memo
  1067. ENDCASE
  1068. {    lmarg(0)}
  1069. RETURN
  1070.  
  1071. {    print("*"+replicate("-",78)+crlf);}
  1072. PROCEDURE _Edpaste
  1073. {    lmarg(offset)}
  1074. *-- Edit Cut data
  1075. PRIVATE ALL LIKE l?_*
  1076.  
  1077. lc_deli = SET("DELIMITERS")
  1078. lc_form = SET("FORMAT")
  1079. SET DELIMITERS OFF
  1080. SET FORMAT TO
  1081. SAVE SCREEN TO _edpaste
  1082. DEFINE WINDOW _edpaste FROM \
  1083. {    if !(scrn_size == 24 or scrn_size == 42) then
  1084.         scrn_size-2},0 TO {scrn_size},79
  1085. {    else
  1086.         scrn_size-3},0 TO {scrn_size-1},79
  1087. {    endif}
  1088.  
  1089. lc_message = "{paste_msg2}"
  1090. lc_message = IIF("500" $ VERSION(1), ;
  1091.                  LEFT( lc_message, LEN( lc_message) - 17) , lc_message)
  1092. IF .NOT. "500" $ VERSION(1)
  1093.    ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), lc_message
  1094. ENDIF
  1095. ACTIVATE WINDOW _edpaste
  1096. SET MESSAGE TO lc_message
  1097. @ 0,0 GET gc_cut PICTURE "@S78"
  1098. READ
  1099. ON KEY LABEL {on_key_move}
  1100. SET MESSAGE TO
  1101. RELEASE WINDOW _edpaste
  1102. RESTORE SCREEN FROM _edpaste
  1103. RELEASE SCREEN _edpaste
  1104. SET DELIMITERS &lc_deli.
  1105. SET FORM TO (lc_form)
  1106. {    lmarg(0)}
  1107. RETURN
  1108.  
  1109. {    print("*"+replicate("-",78)+crlf);}
  1110. PROCEDURE _MoveWind
  1111. PARAMETER wind_name, message
  1112. {    lmarg(offset)}
  1113. *----------------------------------------------------------
  1114. *- Move the &wind_name. window based on arrow keys.  Any 
  1115. *- other key stops the move process.
  1116. *----------------------------------------------------------
  1117. ON KEY LABEL {on_key_move}
  1118. ON ERROR ?? CHR(7)
  1119. SET MESSAGE TO
  1120. DO WHILE .T.
  1121.   SET MESSAGE TO {wind_msg1}
  1122.   ln_keyhit = INKEY(0)
  1123.   IF ln_keyhit <> 0
  1124.     DO CASE
  1125.       CASE ln_keyhit = kn_RghtArw               && Right arrow
  1126.          MOVE WINDOW &wind_name. BY 0,1
  1127.       CASE ln_keyhit = kn_UpArw                 && Up arrow
  1128.          MOVE WINDOW &wind_name. BY -1,0
  1129.       CASE ln_keyhit = kn_LeftArw               && Left arrow
  1130.          MOVE WINDOW &wind_name. BY 0,-1
  1131.       CASE ln_keyhit = kn_DownArw               && Down Arrow
  1132.          MOVE WINDOW &wind_name. BY 1,0
  1133.       OTHERWISE
  1134.          EXIT
  1135.     ENDCASE
  1136.   ENDIF
  1137. ENDDO
  1138. ON ERROR
  1139. ON KEY LABEL {on_key_move} DO _MoveWind WITH WINDOW(), "&message."
  1140. SET MESSAGE TO message
  1141. {    lmarg(0)}
  1142. RETURN
  1143. *-- EOP: _MoveWind
  1144.  
  1145. {    print("*"+replicate("-",78)+crlf);}
  1146. FUNCTION _numdec
  1147. PARAMETER ln_dec
  1148. IF ln_dec - INT(ln_dec) > 0
  1149.    RETURN .T.
  1150. ELSE
  1151.    RETURN .F.
  1152. ENDIF
  1153. *-- EOF: _numdec
  1154.  
  1155. {    print("*"+replicate("-",78)+crlf);}
  1156. FUNCTION Center
  1157. *-- UDF to center a string.
  1158. *-- lc_string = String to center
  1159. *-- ln_width = Width of screen to center in
  1160. *--
  1161. *-- Ex. @ 15,center(string,80) say string
  1162. *-- Will center the <string> withing 80 columns
  1163. PARAMETER lc_string, ln_width
  1164. RETURN ((ln_width/2)-(LEN(lc_string)/2))
  1165. *-- EOP: Center()
  1166.  
  1167. {print("*"+replicate("-",78)+crlf);}
  1168. PROCEDURE _key_vars
  1169. *----------------------------------------------------------------------------
  1170. * Enumerate the key values for LASTKEY() and INKEY() functions
  1171. *
  1172. * To check for the Escape key after the INKEY()
  1173. * 
  1174. *   ln_key = INKEY(0)   && Wait for any key press
  1175. *   IF ln_key = kn_Esc  && Escape was pressed
  1176. *     DO esc_hand
  1177. *   ENDIF
  1178. *
  1179. *----------------------------------------------------------------------------
  1180. IF TYPE("kn_end") = "U"
  1181. {lmarg(offset)}
  1182. PUBLIC kn_End     , kn_Tab     , kn_Enter   , kn_CtrlEnd , kn_CtrlY   , ;
  1183.        kn_Home    , kn_Esc     , kn_CtrlHme , kn_CtrlPDn , kn_CtrlPUp , ;
  1184.        kn_Space   , kn_BakSpce , kn_RghtArw , kn_UpArw   , kn_LeftArw , ;
  1185.        kn_DownArw , kn_PgDn    , kn_PgUp    , kn_F1      , kn_Del     , ;
  1186.        kn_CtrLArw , kn_CtrRArw , kn_f7      , kn_ShftF7
  1187.  
  1188.   kn_End     =   2      && Ctrl-B
  1189.   kn_Tab     =   9      && Ctrl-I
  1190.   kn_Enter   =  13      && Ctrl-M
  1191.   kn_CtrlEnd =  23      && Ctrl-W
  1192.   kn_CtrlY   =  25
  1193.   kn_Home    =  26      && Ctrl-Z
  1194.   kn_Esc     =  27      && Ctrl-[
  1195.   kn_CtrlHme =  29      && Ctrl-]
  1196.   kn_CtrlPDn =  30      && Ctrl-PgDn
  1197.   kn_CtrlPUp =  31      && Ctrl-PgUp
  1198.   kn_Space   =  32
  1199.   kn_BakSpce = 127
  1200.   kn_RghtArw =   4      && Ctrl-D
  1201.   kn_UpArw   =   5      && Ctrl-E
  1202.   kn_LeftArw =  19      && Ctrl-S
  1203.   kn_DownArw =  24      && Ctrl-X
  1204.   kn_PgDn    =   3      && Ctrl-C
  1205.   kn_PgUp    =  18      && Ctrl-R
  1206.   kn_F1      =  28      && Ctrl-\
  1207.   kn_Del     =   7      && Ctrl-G
  1208.   kn_CtrLArw =   1      && Ctrl-A
  1209.   kn_CtrRArw =   6      && Ctrl-F
  1210.   kn_F7      =  -6
  1211.   kn_ShftF7   = -26
  1212.  
  1213. *----------------------------------------------------------------------------
  1214. * Enumerate the key values for READKEY()
  1215. *
  1216. * To check to see if data has changed
  1217. *
  1218. *   IF READKEY() >= rn_updated   && Data has changed
  1219. *     REPLACE name WITH m->name
  1220. *   ENDIF
  1221. *
  1222. * To check for page down regardless of data change
  1223. *
  1224. *   ln_readkey = READKEY()
  1225. *   IF ln_readkey = rn_PgDn .OR. ln_readkey = rn_PgDn+rn_Updated
  1226. *     DO pgdn_hand
  1227. *   ENDIF
  1228. *
  1229. *----------------------------------------------------------------------------
  1230. PUBLIC rn_Updated , rn_LeftArw , rn_BakSpce , rn_RghtArw , rn_CtrLArw , ;
  1231.        rn_CtrRArw , rn_UpArw   , rn_DownArw , rn_PgUp    , rn_PgDn    , ;
  1232.        rn_Esc     , rn_CtrlEnd , rn_Enter   , rn_EnterA  , rn_CtrlHme , ;
  1233.        rn_CtrlPUp , rn_CtrlPDn , rn_F1
  1234.  
  1235.   rn_Updated = 256      && Add to rn_key value for updated condition
  1236.   rn_LeftArw =   0      && Includes Ctrl-S and Ctrl-H - backward one character
  1237.   rn_BakSpce =   0      && backward one character                                   
  1238.   rn_RghtArw =   1      && Includes Ctrl-D and Ctrl-L - forward one character
  1239.   rn_CtrLArw =   2      && Ctrl-Left Arrow, includes Ctrl-A - previous word
  1240.   rn_CtrRArw =   3      && Ctrl-Right Arrow, includes Ctrl-F - next word
  1241.   rn_UpArw   =   4      && Includes Ctrl-E and Ctrl-K - backward one field
  1242.   rn_DownArw =   5      && Includes Ctrl-J and Ctrl-X - forward one field
  1243.   rn_PgUp    =   6      && Includes Ctrl-R - backward one screen
  1244.   rn_PgDn    =   7      && Includes Ctrl-C - forward one screen
  1245.   rn_Esc     =  12      && Includes Ctrl-Q - Terminate w/o save
  1246.   rn_CtrlEnd =  14 + rn_updated  && Includes Ctrl-W - Terminate w/save
  1247.   rn_Enter   =  15      && Includes Ctrl-M  RETURN of fill last record
  1248.   rn_EnterA  =  16      && Enter at the beginning of a record in APPEND
  1249.   rn_CtrlHme =  33      && Ctrl-Home - Menu display toggle
  1250.   rn_CtrlPUp =  34      && Ctrl-PgUp - Zoom Out
  1251.   rn_CtrlPDn =  35      && Ctrl-PgDn - Zoom In
  1252.   rn_F1      =  36      && Help function key
  1253. {lmarg(0)}
  1254. ENDIF
  1255.  
  1256. RETURN
  1257. *-- EOP: _key_vars
  1258.  
  1259. {return;
  1260. enddef
  1261.  
  1262. //--------------------------------------------------------------
  1263.  
  1264. define check_for_gen_extensions()
  1265.    // Check for all the different extensions to forms support for this fmt file
  1266.    // Help extension
  1267.    var dbf_name;
  1268.    // next line modified to include rtrim statement per Bill Ramos
  1269.    hlp_name = frame_path + rtrim(substr( fileroot( fmt_name), 1, 6)) + "_H"
  1270.    if fileexist(hlp_name + ".DBF") and fileexist(hlp_name + ".DBT") then
  1271.       is_help = 1      // Global flag for help support
  1272.    // Following lines added by Barry Fox to prompt user for the name of the
  1273.    // the database to check for help support.  This allows the generation 
  1274.    // help support when the form name differs from the parent database 
  1275.    // name.  
  1276.      else
  1277.    dbf_name = askuser("Enter dbf name for help support or press ENTER to continue ","",12)
  1278.    hlp_name = frame_path + rtrim(substr( fileroot( dbf_name), 1, 6)) + "_H"
  1279.    if fileexist(hlp_name + ".DBF") and fileexist(hlp_name+ ".DBT" ) then
  1280.       is_help = 1
  1281.  endif
  1282. endif
  1283.    foreach FLD_ELEMENT flds
  1284.        // Popup or Browse support
  1285.        if popup_or_browse(flds) then
  1286.           is_popup = 1
  1287.           workarea_cnt = workarea_cnt + 1
  1288.        endif
  1289.        // Zoom support
  1290.        if is_zoom(FLD_OK_COND) then
  1291.           is_zoom = 1
  1292.        endif
  1293.        // Recalc support
  1294.        if is_recalc(FLD_DESCRIPT) then
  1295.           is_recalc = 1
  1296.        endif
  1297.        // Replace lookup support
  1298.        if is_replace(FLD_OK_COND) then 
  1299.           is_replace = 1
  1300.        endif
  1301.    next flds
  1302.    if is_help or is_popup or is_zoom or is_recalc or is_replace then
  1303.       return 1;
  1304.    else
  1305.       return 0;
  1306.    endif
  1307. enddef
  1308.  
  1309. //--------------------------------------------------------------
  1310. define popup_or_browse(cur)             // Pass in foreach cursor
  1311.    // Check for "popup" or "browse" string for this fmt file
  1312.    if at("POPUP",  upper(ltrim(cur.FLD_OK_COND))) == "2" or
  1313.       at("BROWSE", upper(ltrim(cur.FLD_OK_COND))) == "2" then
  1314.       return 1;
  1315.    else
  1316.       return 0;
  1317.    endif
  1318. enddef
  1319.  
  1320. //--------------------------------------------------------------
  1321. define new_page(cur)               // Pass in foreach cursor
  1322.    // Checks for a page break and adjusts line_cnt and page_cnt
  1323.    if nul2zero(cur.ROW_POSITN) - line_cnt > scrn_size then
  1324.       line_cnt = line_cnt + scrn_size + 1;
  1325.       ++page_cnt;
  1326.       return 1;
  1327.    endif
  1328. return 0;
  1329. enddef
  1330.  
  1331. //--------------------------------------------------------------
  1332. define parse_line( before,         // Out: chars before the look_for string
  1333.                    input,          // In:  line being parsed
  1334.                    look_for        // In:  string searched for
  1335.                  )                 // Rtn: chars after the look_for string
  1336.      // If the look_for sting is not found, the before sting will equal the
  1337.      // input string, and the returned value will be NUL
  1338.      var location, after;
  1339.  
  1340.      location = at(look_for, upper(input))
  1341.      if location == 0 then
  1342.           before = input
  1343.           return ( "" );
  1344.      endif
  1345.  
  1346.      before = substr( input, 1, location-1)
  1347.      after  = substr( input, location)
  1348.      after  = substr( after, 1, len(after) - 1)
  1349.  
  1350.      return ( alltrim( substr( after,
  1351.                                 1 + len(look_for),
  1352.                                 get_next_key_word(
  1353.                                                   substr( after,
  1354.                                                           1 + len( look_for)
  1355.                                                         )
  1356.                                                   )
  1357.                              )
  1358.                      )
  1359.             );
  1360. // end: parse_line()
  1361. enddef
  1362.  
  1363. //--------------------------------------------------------------
  1364. define get_next_key_word(rest_of_str)   // String to search for keyword
  1365.    var str_length;
  1366.  
  1367.    str_length = len(rest_of_str)
  1368.    rest_of_str = upper(rest_of_str)
  1369.  
  1370.    for cnt = 1 to str_length
  1371.  
  1372.       if at(" ORDER", substr(rest_of_str, cnt)) == 1  or
  1373.          at(" REQ",   substr(rest_of_str, cnt)) == 1  or
  1374.          at(" SHADOW",substr(rest_of_str, cnt)) == 1  or
  1375.          at(" FIELDS",substr(rest_of_str, cnt)) == 1  or
  1376.          at(" UPDATE",substr(rest_of_str, cnt)) == 1  or
  1377.          at(" FORMAT",substr(rest_of_str, cnt)) == 1  or
  1378.          at(" FROM",  substr(rest_of_str, cnt)) == 1  or
  1379.          at(" REPLACE",  substr(rest_of_str, cnt)) == 1  or
  1380.          at(" ZOOM",  substr(rest_of_str, cnt)) == 1  then
  1381.            exit
  1382.       endif
  1383.  
  1384.    next
  1385.    return cnt - 1;
  1386. enddef
  1387.  
  1388. //--------------------------------------------------------------
  1389. // Parsing routines for pulling objects out of the VALID string
  1390. // "POPUP" = "file->fld_name ORDER key_fld REQ"
  1391. // 1234567890123456789012345678901234567890123
  1392. //            1         2         3         4
  1393. define get_file(valid_str)
  1394.      var  s_arrow,            // String "->"
  1395.           test,
  1396.           s_equal,            // String "="
  1397.           next_alpha,
  1398.           at_alias,
  1399.           s_before,           // String before the searched for item
  1400.           r_target,           // Remainder of the target string after item
  1401.           use_name;           // Return for file
  1402.  
  1403.      s_arrow = "->"
  1404.      s_equal = "="
  1405.      r_target = parse_line( s_before, valid_str, s_equal )      // ' "file->...'
  1406.      next_alpha = atalpha(r_target)                             // 3
  1407.      at_alias = at(s_arrow, r_target)                           // 7
  1408.      use_name = substr(r_target,next_alpha,at_alias-next_alpha) // 'file'
  1409.  
  1410.      return cap_first(use_name);
  1411. enddef
  1412.  
  1413. //--------------------------------------------------------------
  1414. define get_udfname(fld_str)
  1415.      // Create UDF name
  1416.      return cap_first( "l_" + substr( fld_str,1,6) );
  1417. enddef
  1418.  
  1419. //--------------------------------------------------------------
  1420. define get_key(valid_str)
  1421.      var  s_order,            // String "ORDER "
  1422.           at_space,
  1423.           s_before,           // String before the searched for item
  1424.           r_target,           // Remainder of the target string after item
  1425.           order_tag;          // Search TAG to ORDER BY
  1426.  
  1427.      s_order = "ORDER "
  1428.      r_target = parse_line( s_before, valid_str, s_order ) // 'key_fld REQ'
  1429.      at_space = at(" ",r_target)
  1430.      if at_space == 0 then
  1431.           order_tag = substr(r_target, 1, len(r_target)) // 'key_fld"'
  1432.      else
  1433.           order_tag = substr(r_target, 1, at_space)
  1434.      endif
  1435.      return cap_first(order_tag);
  1436. enddef
  1437.  
  1438. //--------------------------------------------------------------
  1439. define get_field(valid_str)
  1440.      var  s_arrow,            // String "->"
  1441.           at_space,
  1442.           s_before,           // String before the searched for item
  1443.           r_target,           // Remainder of the target string after item
  1444.           fld_name;           // Field name to lookup in target file
  1445.  
  1446.      s_arrow = "->"
  1447.      r_target = parse_line( s_before,
  1448.                             valid_str, s_arrow ) // 'fld_name ORDER...'
  1449.      at_space = at(" ",r_target)
  1450.  
  1451.      fld_name = ( at_space == 0 ? r_target : substr(r_target, 1, at_space-1) );
  1452.  
  1453.      return cap_first(fld_name);
  1454. enddef
  1455.  
  1456. //--------------------------------------------------------------
  1457. define get_popname(valid_str)
  1458.      // Create popup name
  1459.      return ( lower( "l_" + substr( get_field( valid_str),1,6) ) );
  1460. enddef
  1461.  
  1462. //--------------------------------------------------------------
  1463. define is_required(valid_str)
  1464.      // Determines if the field is required before moving to the next field
  1465.      return ( ( at(" REQ ",  upper(valid_str)) ? 1 : 0 ) or
  1466.               ( at(" REQ\"", upper(valid_str)) ? 1 : 0 )
  1467.             );
  1468. enddef
  1469.  
  1470. //--------------------------------------------------------------
  1471. define is_shadow(valid_str)
  1472.      // Determines if the user wants shadowing for popup
  1473.      return ( ( at(" SHADOW ",  upper(valid_str)) ? 1 : 0 ) or
  1474.               ( at(" SHADOW\"", upper(valid_str)) ? 1 : 0 )
  1475.             );
  1476. enddef
  1477.  
  1478. //--------------------------------------------------------------
  1479. define is_update(valid_str)
  1480.      // Determines if the user wants updating in the BROWSE
  1481.      return ( ( at(" UPDATE ",  upper(valid_str)) ? 1 : 0 ) or
  1482.               ( at(" UPDATE\"", upper(valid_str)) ? 1 : 0 )
  1483.             );
  1484. enddef
  1485.  
  1486. //--------------------------------------------------------------
  1487. define is_format_file(k, valid_str)
  1488.     // Determines if the user has a format file entered and is valid
  1489.     var is_format, format_file;
  1490.  
  1491.     is_format = ( at(" FORMAT ", upper(valid_str)) ? 1 : 0 );
  1492.  
  1493.     if is_format then
  1494.        format_file = parse_line("", k.FLD_OK_COND, "FORMAT ")
  1495.        format_file = (at(".", format_file) ? format_file : format_file + ".fmt");
  1496.        is_format = ( fileexist(format_file) ? 1 : 0 );
  1497.      endif
  1498.  
  1499.      return is_format;
  1500. enddef
  1501.  
  1502. //--------------------------------------------------------------
  1503. define is_window(valid_str)
  1504.      // Determines if the user wants windowing for BROWSE
  1505.      return ( at(" FROM ",upper(valid_str)) ? 1 : 0 );
  1506. enddef
  1507.  
  1508. //--------------------------------------------------------------
  1509. define is_fields(valid_str)
  1510.      // Determines if the user wants to set fields for BROWSE
  1511.      return ( at(" FIELDS ",upper(valid_str)) ? 1 : 0 );
  1512. enddef
  1513.  
  1514. //--------------------------------------------------------------
  1515. define is_zoom(valid_str)
  1516.      // Determines if the field wants zoom before moving to the next field    
  1517.      return ( ( at(" ZOOM ",  upper(valid_str)) ? 1 : 0 ) or
  1518.               ( at(" ZOOM\"", upper(valid_str)) ? 1 : 0 )
  1519.             );
  1520. enddef
  1521.  
  1522. //--------------------------------------------------------------
  1523. define is_recalc(descrip_str)
  1524.      // Determines if the users wants recalc on calculated fields
  1525.      return  ( at("RECALC",  upper(descrip_str)) ? 1 : 0 );
  1526. enddef
  1527.  
  1528. //--------------------------------------------------------------
  1529. define is_replace(valid_str)
  1530.      // Determines if the users wants recalc on calculated fields
  1531.      return  ( at(" REPLACE ",  upper(valid_str)) ? 1 : 0 );
  1532. enddef
  1533.  
  1534. //--------------------------------------------------------------
  1535. define get_pop_shadow(field_template)   // Pass in FLD_TEMPLATE to deter. shadow
  1536.      if trow_positn < max_pop_row then
  1537.         trow_positn + 1},{tcol_positn},{scrn_size-1},{tcol_positn+len(Field_template)+1}
  1538. {    else
  1539.         trow_positn - 11},{tcol_positn},{trow_positn - 1},{tcol_positn+len(Field_template)+1}
  1540. {    endif
  1541.      return;
  1542. enddef
  1543.  
  1544. //--------------------------------------------------------------
  1545. define get_browse_shadow(from_to)
  1546.      // Determine shadow coordinates for BROWSE
  1547.  
  1548.      var from_clause, from_coord, to_coord, r1, c1, r2, c2;
  1549.  
  1550.      // Get From clause for the DEFINE WINDOW
  1551.      from_clause = alltrim( upper( parse_line("", from_to, "FROM ")))
  1552.  
  1553.      if !from_clause then return ""; endif
  1554.  
  1555.      // Get FROM coordinates
  1556.      from_coord = alltrim( substr( from_clause, 1, at("TO", from_clause) - 1))
  1557.      r1 = substr( from_coord, 1, at(",", from_coord)-1)
  1558.      c1 = substr( from_coord, at(",", from_coord)+1)
  1559.  
  1560.      // Get TO coordinates
  1561.      to_coord   = alltrim( substr( from_clause, at("TO", from_clause) + 2))
  1562.      r2 = substr( to_coord, 1, at(",", to_coord)-1)
  1563.      // Check shadow height and adjust if necessary
  1564.      r2 = (val( r2) + 1) <= scrn_size ? r2 : str( scrn_size - 1) ;
  1565.  
  1566.      c2 = substr( to_coord, at(",", to_coord)+1)
  1567.      // Check shadow width and adjust if necessary
  1568.      c2 = (val(c2)+2) <= 79 ? c2 : str(77) ;
  1569.  
  1570.      print( r1 + "," + c1 + "," + r2 + "," + c2)
  1571.      return;
  1572. enddef
  1573.  
  1574. //--------------------------------------------------------------
  1575. define get_browse_fields_list(k)
  1576.   // Search for "FIELDS" in FLD_OK_COND and return the field list for BROWSE
  1577.   var field_list, key_length;
  1578.  
  1579.   field_list = parse_line("", k.FLD_OK_COND, "FIELDS ")
  1580.   key_length = len( temp_key)
  1581.  
  1582.   if is_update(k.FLD_OK_COND) then
  1583.     // Add /R readonly flag to KEY field of lookup table, if updateable
  1584.     return substr( field_list, 1, at( upper(temp_key), upper(field_list)) + key_length -1)
  1585.             + " /R" +
  1586.           substr( field_list, at( upper(temp_key), upper(field_list)) + key_length);
  1587.   else
  1588.     return field_list;
  1589.   endif
  1590. enddef
  1591.  
  1592. //--------------------------------------------------------------
  1593. define get_browse_window(k)
  1594.   // Search for "FROM" in FLD_OK_COND and return the list for BROWSE
  1595.   return parse_line("", k.FLD_OK_COND, "FROM ");
  1596. enddef
  1597.  
  1598. //--------------------------------------------------------------
  1599. define get_format_file(_file)
  1600.   // Search for "FORMAT" in FLD_OK_COND and return the NAME for BROWSE
  1601.   return cap_first(parse_line("", _file, "FORMAT "))
  1602. enddef
  1603.  
  1604. define get_zoom_format_file(_file)
  1605.  // Search for "ZOOM" in FLD_OK_COND and return the FORMAT NAME for EDIT
  1606.   return cap_first(parse_line("", _file, "ZOOM "));
  1607. enddef
  1608.  
  1609. define make_zoom_to_form()
  1610.   var zoom_name, lookup_dbf;
  1611.   zoom_name = "Z_" + lower(rtrim(substr(name,1,6)))
  1612.   if !is_zoom then
  1613.     return 0;
  1614.   endif
  1615.   print(crlf + "*"+replicate("-",78)+crlf);
  1616. }
  1617. PROCEDURE {zoom_name}
  1618. *-- Branch to another EDIT form based on lc_var
  1619. PARAMETER lc_var
  1620. PRIVATE ALL LIKE l?_*
  1621.  
  1622. ON KEY LABEL {on_key_zoom}
  1623. SAVE SCREEN TO {zoom_name}
  1624. lc_area = ALIAS()
  1625. ll_edit = .F.
  1626. SELECT SELECT()
  1627. DO CASE
  1628. {  foreach FLD_ELEMENT flds
  1629.       if is_zoom( FLD_OK_COND) then
  1630.         lookup_dbf = get_file( FLD_OK_COND);
  1631. }
  1632.    CASE lc_var = "{FLD_FIELDNAME}"
  1633. {        if workarea_cnt > max_workareas then}
  1634.       IF FILE("{lookup_dbf}.dbf")
  1635.          USE {lookup_dbf} ORDER {alltrim(get_key( FLD_OK_COND))}
  1636. {            if chr( FLD_VALUE_TYPE) == "C" then}
  1637.          lc_var = IIF( EMPTY( TRIM( lc_var)), lc_var, TRIM( lc_var))
  1638. {            endif
  1639.          else
  1640. }
  1641.          SELECT ("{ upper(lookup_dbf) == FLD_FILENAME ? 
  1642.                                               "A"+substr(lookup_dbf,1,7) : 
  1643.                                                lookup_dbf}")
  1644. {         endif   }
  1645.          SEEK &lc_area.->&lc_var.
  1646.  
  1647.          IF FILE("{fileroot( get_zoom_format_file( FLD_OK_COND)) + ".FMT"}")
  1648.              SET FORMAT TO {fileroot( get_zoom_format_file(FLD_OK_COND))}
  1649.          ENDIF
  1650.          ll_edit = .T.
  1651. {        if workarea_cnt > max_workareas then}
  1652.       ENDIF
  1653. {         endif
  1654.       endif       
  1655.    next
  1656. }
  1657.    OTHERWISE
  1658.        KEYBOARD CHR( kn_CtrlHme ) CLEAR          && Gets user into memo field
  1659. ENDCASE
  1660.  
  1661. IF ll_edit
  1662.    EDIT NEXT 1                                   && Edit the Zoomed record
  1663. ENDIF
  1664.  
  1665. {  if workarea_cnt > max_workareas then}
  1666. USE
  1667. {  endif}
  1668. SELECT (lc_area)                                 && Back to edit work area
  1669. RESTORE SCREEN FROM {zoom_name}
  1670. RELEASE SCREEN {zoom_name}
  1671. {  if is_help then}
  1672. ON KEY LABEL {on_key_help} DO {"H_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
  1673. {  endif
  1674.    if is_recalc then}
  1675. ON KEY LABEL {on_key_recalc} DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
  1676. {  endif}
  1677. ON KEY LABEL {on_key_cut} DO _Cut
  1678. ON KEY LABEL {on_key_paste} DO _Paste
  1679. ON KEY LABEL {on_key_edpaste} DO _Edpaste
  1680. ON KEY LABEL {on_key_zoom} DO {zoom_name} WITH VARREAD()
  1681. RETURN
  1682. *-- EOP: {zoom_name}
  1683. {enddef
  1684.  
  1685. define make_recalc_code()
  1686.   var recalc_name;
  1687.   recalc_name = "R_" + lower(rtrim(substr(name,1,6)))
  1688.   if !is_recalc then
  1689.     return 0;
  1690.   endif
  1691.   if !udf_file then
  1692.      if !make_udf() then
  1693.         return 0;
  1694.      endif
  1695.      // Put up the UDF header
  1696.      udf_header()
  1697.   endif
  1698.   print(crlf + "*"+replicate("-",78)+crlf);
  1699. }
  1700. PROCEDURE {recalc_name}
  1701. *-- Recalculate calculated fields
  1702. PARAMETER lc_var
  1703. PRIVATE ALL LIKE l?_*
  1704. ON KEY LABEL {on_key_recalc}
  1705.  
  1706. {textopen( fmt_name + ".tmp")
  1707.  temp = textgetl();
  1708.  if page_cnt > 1 then
  1709. }
  1710. DO CASE
  1711.    CASE lc_var $ "{temp}"
  1712. {   lmarg(offset*2)
  1713.  endif
  1714.  color_flg = line_cnt = 0;
  1715.  foreach FLD_ELEMENT k
  1716.    if new_page(k) then
  1717.       temp = textgetl();
  1718.       lmarg(offset)
  1719. }
  1720.  
  1721.  CASE lc_var $ "{temp}"
  1722. {     lmarg(offset*2)
  1723.    endif
  1724.    color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  1725.    if FLD_FIELDTYPE == calc and is_recalc(FLD_DESCRIPT) then}
  1726. *-- Calculated field: {cap_first(FLD_FIELDNAME)} - {FLD_DESCRIPT}
  1727. @ {nul2zero(ROW_POSITN) - line_cnt},{nul2zero(COL_POSITN)} SAY \
  1728. {  // Loop thru expression in case it is longer than 237
  1729.        foreach FLD_EXPRESSION fcursor in k
  1730.           FLD_EXPRESSION}
  1731. {      next}
  1732. // Output a space after the Fld_expression and get ready for picture clause
  1733.  \
  1734. {      if Ok_Template(k) then}
  1735. PICTURE "{picture_for_say(k);}" \
  1736. {      endif
  1737.        outcolor()}
  1738.  
  1739. {  endif
  1740.  next k;
  1741.  if page_cnt > 1 then
  1742.    lmarg(0)
  1743. }
  1744. ENDCASE
  1745. {endif}
  1746.  
  1747. ON KEY LABEL {on_key_recalc} DO {"R_" + lower(rtrim(substr(name,1,6)))} WITH VARREAD()
  1748. RETURN
  1749. *-- EOP: {recalc_name}
  1750. { textclose()
  1751.   fileerase( fmt_name + ".tmp")
  1752. enddef
  1753.  
  1754. define write_recalc_get_list()
  1755.  if is_recalc then                // Write get list out for each page
  1756.     append( fmt_name + ".tmp")    // Used for "recalc" option
  1757.     print( get_list + crlf)
  1758.     append( fmt_name + ".fmt")
  1759.  endif
  1760. enddef
  1761.  
  1762. //--------------------------------------------------------------
  1763. define make_replace_code()
  1764.   // Make REPLACE and @ GET statements for other fields related to the LOOKUP
  1765.   var replace_field_name, field_list, temp2;
  1766.  
  1767.   if !is_replace then
  1768.     return 0;
  1769.   endif
  1770.  
  1771.   color_flg = line_cnt = 0;
  1772.  
  1773.   foreach FLD_ELEMENT x
  1774.     if is_replace( FLD_OK_COND ) then  // found a field with REPLACE
  1775.       replace_field_name = "U_" + lower( rtrim( substr( FLD_FIELDNAME, 1, 7)));
  1776.       print(crlf + "*"+replicate("-",78)+crlf);
  1777. }
  1778. PROCEDURE {replace_field_name} 
  1779.    PARAMETER is_edit, key_field
  1780.    *-- Update Look'ed up fields for {cap_first( FLD_FIELDNAME )}
  1781.  
  1782. {     if  at("POPUP", upper(ltrim(FLD_OK_COND))) then}
  1783.    SEEK key_field
  1784.  
  1785. {     endif
  1786.       lmarg(4)
  1787.       get_replace_fields_list(x) 
  1788.       get_memvar_fields_list(x) 
  1789.       lmarg(0)
  1790. }
  1791.  
  1792.    IF is_edit
  1793. {     foreach FLD_ELEMENT y
  1794.          if is_replace( y.FLD_OK_COND) and x == y then
  1795.  
  1796.              field_list = upper( parse_line( "", y.FLD_OK_COND, "REPLACE ") )
  1797.              do while len(field_list) > 0
  1798.                 temp = upper( substr( field_list, 1, at(" WITH", field_list) - 1 ))
  1799.                 temp2 = at("M->",  upper(temp)) ?
  1800.                        substr( temp, at("M->", upper(temp)) + 3 ) :
  1801.                        temp;
  1802.                 foreach FLD_ELEMENT z
  1803.                    if FLD_FIELDNAME == alltrim( temp2 ) then
  1804.                       color = getcolor(z.FLD_DISPLAY, z.FLD_EDITABLE); // get color of element
  1805. }
  1806.       @ {z.ROW_POSITN},{z.COL_POSITN} GET \
  1807. {                     if at("M->",  upper(temp)) then
  1808.                          temp}
  1809. {                     else
  1810.                          cap_first(z.FLD_FILENAME)}->\
  1811. {                        cap_first(z.FLD_FIELDNAME)}\
  1812. {                     endif
  1813.                       if Ok_Template(z) then}
  1814.  PICTURE "{picture_for_get(z);}" \
  1815. {                        outcolor()}
  1816. {                     endif}
  1817.  
  1818. {                     exit
  1819.                    endif
  1820.                 next z
  1821.                 if at( ",", field_list) > 0 then
  1822.                    field_list = substr( field_list, at( ",", field_list) + 1 )
  1823.                 else
  1824.                    field_list = ""
  1825.                 endif
  1826.              enddo
  1827. }
  1828.    ENDIF
  1829. RETURN
  1830. *-- EOP: {replace_field_name}
  1831.  
  1832. {            exit
  1833.          endif
  1834.       next y 
  1835.     endif
  1836.   next x
  1837.  return;
  1838. enddef
  1839.  
  1840. //--------------------------------------------------------------
  1841. define get_replace_fields_list(k)
  1842.   // Search for "REPLACE" in FLD_OK_COND and return the field list for REPLACE
  1843.   var field_list, key_length, first_loop;
  1844.  
  1845.   first_loop = 1;
  1846.   // Get REPLACE field data
  1847.   field_list = upper( parse_line( "",k.FLD_OK_COND, "REPLACE ") )
  1848.  
  1849.   // Fix the data up and print on multiple lines
  1850.   do while len( field_list) > 0
  1851.      if !at("M->", upper(substr(field_list, 1, at(" WITH", field_list) - 1 ))) then
  1852.         if first_loop then
  1853.            print("REPLACE ")
  1854.            first_loop = 0
  1855.         else
  1856.            print( ", ;" + crlf + space( 7))
  1857.         endif
  1858.         print( cap_first( k.FLD_FILENAME) + "->" +
  1859.                 cap_first(alltrim(substr(field_list, 1, at(" WITH", field_list) - 1 ))) +
  1860.                 " WITH "
  1861.              )
  1862.  
  1863.         temp = cap_first( alltrim( substr( field_list, at( "WITH", field_list) + 4 )))
  1864.         if at( ",", temp) > 0 then
  1865.            temp = substr( temp, 1, at( ",", temp) - 1 )
  1866.         endif
  1867.  
  1868.         print( temp)
  1869.      endif
  1870.      if at( ",", field_list) > 0 then
  1871.         field_list = substr( field_list, at(",", field_list) + 1 );
  1872.         if len( alltrim( field_list) ) == 0 then
  1873.            field_list = ""
  1874.         endif
  1875.      else
  1876.         field_list = ""
  1877.      endif
  1878.   enddo
  1879.   print( crlf )
  1880.   return ;
  1881. enddef
  1882.  
  1883. define get_memvar_fields_list(k)
  1884.   // Search for "REPLACE" in FLD_OK_COND and return the field list for MEMVAR
  1885.   // declaration
  1886.   var field_list, key_length;
  1887.  
  1888.   field_list = upper( parse_line( "",k.FLD_OK_COND, "REPLACE ") )
  1889.   // Produce memvar statements instead of replace statements
  1890.   do while len( field_list) > 0
  1891.      if at("M->", upper(substr(field_list, 1, at(" WITH", field_list) - 1 ))) then
  1892.         // Before "WITH"
  1893.         print( cap_first( alltrim( substr(field_list, 1, 
  1894.                        at(" WITH", field_list) - 1 ))) +
  1895.                 " = "
  1896.              )
  1897.         // After "WITH"
  1898.         temp = cap_first( alltrim( substr( field_list, at( "WITH", field_list) + 4 )))
  1899.         if at( ",", temp) > 0 then
  1900.            temp = substr( temp, 1, at( ",", temp) - 1 )
  1901.         endif
  1902.         print( temp + crlf)
  1903.      endif
  1904.  
  1905.      if at( ",", field_list) > 0 then
  1906.          field_list = substr( field_list, at(",", field_list) + 1 )
  1907.         if len( alltrim( field_list) ) == 0 then
  1908.            field_list = ""
  1909.         endif
  1910.      else
  1911.         field_list = ""
  1912.      endif
  1913.   enddo
  1914.   return ;
  1915. enddef
  1916.  
  1917. define make_memvar_declarations()
  1918.     // Make memvars for lookups
  1919.     foreach FLD_ELEMENT 
  1920.        if FLD_FIELDTYPE == memvar then
  1921. }
  1922. IF TYPE("M->{FLD_FIELDNAME}") = "U"
  1923.    m->{FLD_FIELDNAME} = \
  1924. {          if chr(FLD_VALUE_TYPE) == "C" then
  1925.                print("SPACE(" + len(FLD_TEMPLATE) + ")")
  1926.            endif
  1927.           if at(chr(FLD_VALUE_TYPE), "NF") then
  1928.                print("0")
  1929.            endif
  1930.           if chr(FLD_VALUE_TYPE) == "D" then
  1931.                print("{  \  \  }")
  1932.            endif
  1933.           if chr(FLD_VALUE_TYPE) == "L" then
  1934.                print(".F.")
  1935.            endif     //
  1936.            print(crlf)
  1937. }
  1938. ENDIF
  1939. {
  1940.        endif
  1941.      next
  1942. return ;     
  1943. enddef
  1944. }
  1945.