home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a031 / template.exe / FORM.COD < prev    next >
Encoding:
Text File  |  1992-03-10  |  55.2 KB  |  1,832 lines
  1. // Module Name: FORM.COD FOR 1.5
  2. // Description: This module produces dBASE IV .FMT files
  3. //              with popups for VALID clause field validation and
  4. //              Context Sensitive Help for each field
  5. //
  6.  
  7. Format (.fmt) File Template with POPUP field validation
  8. -------------------------------------------------------
  9. Copyright (c) 1987, 1990, 1991, 1992 Borland International, Inc.
  10.  
  11.  
  12. This template will support POPUPs for VALID clause field validations and
  13. context sensitive help for each field.
  14.  
  15. Example: In "ACCEPT value when" under "Edit options" enter,
  16.         "POPUP" = "vendor->vendor_id ORDER vendor_id REQ SHADOW"
  17.         --------------------------------------------------------
  18.         this will activate a popup if the data entered is invalid for
  19.         that field and will also make the field REQUIRED.
  20.  
  21. Explanation of the POPUP string follows:
  22.  
  23. POPUP              Indicates that a popup will be used for this field.
  24. vendor->vendor_id  Indicates the .DBF to open and FIELD to use as validation.
  25. ORDER vendor_id    Indicates which INDEX TAG to SEEK in.
  26. REQ                Indicates the FIELD requires data (can't be empty).
  27.                    Leave REQ out if the field is NOT required.      OPTIONAL!
  28. SHADOW             Use shadowing effect on popups                   OPTIONAL!
  29. NOTE: The POPUP string must be entered with the quotes as in the example.
  30.  
  31. --------------------------------------------------------------------------------
  32.  
  33. Explanation of the Context Sensitive Help file follows:
  34.  
  35. If you want to create your own help file, here is the structure that is required.
  36.  
  37. Structure for Help Database (.dbf):
  38. <first 6 chars. of the format file name>_H.dbf
  39.  
  40. Field   Field Name  Type        Width  Dec   Tag
  41. -------------------------------------------------
  42.     1   FLD_NAME    Character     10         Yes  Field name to lookup on F1
  43.     2   FLD_HEADNG  Character     25          No  Heading to show user on window
  44.     3   FLD_HELP    Memo          10          No  Help text to show user
  45. -------------------------------------------------
  46.         Total                     46
  47. {
  48. include "form.def"    // Form selectors
  49. include "builtin.def" // Builtin functions
  50.  if getenv("dtl_debug") then
  51.    debug(2)
  52.    breakpoint( pick_debug )
  53.  endif
  54.  
  55. //
  56. // Enum string constants for international translation
  57. //
  58.  // Enum's for ON KEY labels AND error strings in FORM.DEF
  59.  enum  TRUE  = 1,
  60.        FALSE = 0,
  61.        offset = 2,         // Offset for lmarg()
  62.        range_require  = 2, // Bit for range required set
  63.        valid_required = 4, //  "   "  edit     "      "
  64.        screen_width = 80,  // Screen width for now
  65.        err_ext = ".err"
  66.  ;
  67. //
  68.  
  69.  var  bnl_formname,     // Name of BNL file to newframe if argument() has value
  70.       create_error,     // Indicates if there were problems creating programs
  71.       arg_list;
  72.  
  73.  arg_list = argument()
  74.  if arg_list != "" then
  75.    bnl_formname = token( ",", arg_list, 1 )
  76.    if !newframe( bnl_formname ) then
  77.      return -1;
  78.    endif
  79.  endif
  80.  
  81.  if FRAME_CLASS != form then // We are not processing a form object
  82.    pause(wrong_class + any_key)
  83.    goto NoGen;
  84.  endif
  85.  
  86.  
  87. var  fmt_name,     // Format file name
  88.      crlf,         // line feed
  89.      carry_flg,    // Flag to test carry loop
  90.      carry_cnt,    // Count of the number of fields to carry
  91.      carry_len,    // Cumulative length of carry line until 75 characters
  92.      carry_lent,   // Total cumulative length of carry line
  93.      base_name,        // First 6 characters of the NAME selector
  94.      procedure_name,   // First 7 characters of the NAME selector
  95.      udf_filename,     // UDF file name grabbed from .scb file
  96.      lookup_cnt,
  97.      carry_first,  // Flag to test "," output for carry fields
  98.      color_flg,    // Flag to if color should stay on am line
  99.      line_cnt,     // Count for total lines processed (Mulitple page forms)
  100.      page_cnt,     // Count for total pages processed (Mulitple page forms)
  101.      temp,         // tempory work variable
  102.      cnt,          // Foreach loop variable
  103.      wnd_cnt,      // Window counter
  104.      wnd_names,    // Window names so I can clear them at the bottom of the file
  105.      default_drv,  // dBASE default drive
  106.      dB_status,    // dBASE status before entering designer
  107.      scrn_size,    // Screen size when generation starts
  108.      left_delimiter, // Delimiter to put around SAY
  109.      right_delimiter,// Delimiter to put around SAY
  110.      max_pop_row,  // Maximum row that a popup or shadow can start
  111.      display,      // Type of display screen we are on
  112.      is_popup,     // POPUP validation requested
  113.      is_help,      // HELP (context sensitive) requested
  114.      udf_file,     // UDF file has been created
  115.      hlp_name,     // HELP .dbf name
  116.      trow_positn,  // Temporary variable for row_positn
  117.      tcol_positn,  // Temporary variable for col_positn
  118.      at_pop,       // "POPUP" is in FLD_OK_COND
  119.      master_file,  // Name of master alias based on first field on form
  120.      workarea_dbfs,// DBF files opened on the surface , delimited
  121.      color;        // Color returned from getcolor function
  122.  
  123.  //-----------------------------------------------
  124.  // Assign default values to some of the variables
  125.  //-----------------------------------------------
  126.  carry_flg = carry_first = carry_cnt = carry_len = carry_lent =
  127.  wnd_cnt = line_cnt =  color_flg = cnt = 0
  128.  crlf = chr(10)
  129.  master_file = workarea_dbfs = temp = ""
  130.  page_cnt = 1
  131.  is_popup = is_help = udf_file = 0
  132.  left_delimiter = right_delimiter = "\""
  133.  procedure_name = lower( rtrim( substr( NAME, 1, 7 )))
  134.  base_name      = lower( rtrim( substr( NAME, 1, 6 )))
  135.  udf_filename = "U_" + base_name
  136.  
  137.  screen_size()
  138.  //-------------------------------
  139.  // Create Format file
  140.  //-------------------------------
  141.  if !make_Fmt() then goto nogen
  142.  
  143.  header()                   // Print Header in the Format file
  144.  fmt_file_initialization()  // Format file initializtion code
  145.  fmt_file_body()            // @ SAY GET Processing
  146.  fmt_file_exit()            // Format file exit code
  147.  make_pop_code()            // Create the Procedure File for POPUP's if required
  148.  make_help_code()           // Make procedures for the help system
  149.  if is_popup || is_help then
  150.    make_general_procs();
  151.  endif
  152.  
  153.  fileerase(fmt_name+".FMO")
  154.  nogen:
  155. return 0;
  156.  
  157.  
  158. //---------------------------------------
  159. // Template user defined functions follow
  160. //---------------------------------------
  161.  
  162. define fmt_file_initialization()
  163. //
  164. // Format file initialization code
  165. //
  166. }
  167.  
  168. *-- Format file initialization code --------------------------------------------
  169.  
  170. *-- Some of these PRIVATE variables are created based on CodeGen and may not 
  171. *-- be used by your particular .fmt file
  172. PRIVATE ll_talk, ll_cursor, lc_display, lc_status, ll_carry, lc_proc
  173.  
  174. IF SET("TALK") = "ON"
  175.   SET TALK OFF
  176.   ll_talk = .T.
  177. ELSE
  178.   ll_talk = .F.
  179. ENDIF
  180. ll_cursor = SET("CURSOR") = "ON"
  181. SET CURSOR ON
  182. {if at("43", display_type()) then}
  183.  
  184. *-- This form was created in {display_type()} mode
  185. lc_display = SET("display")
  186. // MONO, COLOR, EGA25, EGA43, MONO43
  187. IF .NOT. "43" $ lc_display{tabto(41)}&& In 25 line mode
  188.   IF "EGA" $ lc_display
  189.     *-- If EGA is in lc_display try EGA43
  190.     SET DISPLAY TO EGA43                     
  191.   ELSE
  192.     *-- Otherwise try MONO43
  193.     SET DISPLAY TO MONO43
  194.   ENDIF
  195. ENDIF
  196. {endif}
  197.  
  198. lc_status = SET("STATUS")
  199. *-- SET STATUS was \
  200. {if dB_status then}
  201. ON when you went into the Forms Designer.
  202. IF lc_status = "OFF"
  203.    SET STATUS ON
  204. {else}
  205. OFF when you went into the Forms Designer.
  206. IF lc_status = "ON"
  207.    SET STATUS OFF
  208. {endif}
  209. ENDIF
  210. //-----------------------------------------------------------------------
  211. // Process fields to build "SET CARRY" and WINDOW commands.
  212. //-----------------------------------------------------------------------
  213. {
  214.   foreach FLD_ELEMENT flds
  215.     if FLD_CARRY then 
  216.       carry_flg = 1; 
  217.       ++carry_cnt ;
  218.     endif
  219.     if chr(FLD_VALUE_TYPE) == "M" and FLD_MEM_TYP and wnd_cnt < 20 then
  220.       ++wnd_cnt;
  221.       wnd_names = wnd_names + "wndow" + wnd_cnt + ",";
  222.       new_page(flds);
  223. }
  224.  
  225. *-- Window for memo field {cap_first(FLD_FIELDNAME)}.
  226. DEFINE WINDOW { Window_Def(flds)}\
  227. {   endif
  228.   next flds
  229.   print(crlf);
  230.   if carry_flg then
  231. }
  232.  
  233. ll_carry = SET("CARRY") = "ON"
  234. SET CARRY ON
  235. *-- Fields to carry forward during APPEND.
  236. SET CARRY TO{tabto(41)}&& Clear previous SET CARRY TO list
  237. SET CARRY TO { Carry_Flds()}
  238.  
  239. {endif}
  240. {
  241.   if check_for_popups() then
  242. }
  243.  
  244. ON KEY LABEL F2 ?? chr(7)
  245.  
  246. {   output_set_proc_code();}
  247. DO S_{procedure_name}{tabto(41)}&& Open up Lookup Files
  248.  
  249. {   endif
  250.     if check_for_help() then
  251.       if !is_popup then}
  252. {         output_set_proc_code();}
  253. {       endif}
  254. ON KEY LABEL F1 DO Help WITH VARREAD()
  255. { endif
  256. return;
  257. // eof - fmt_file_init()
  258. enddef
  259.  
  260. //--------------------------------------------------------------
  261. define fmt_file_body()
  262.   var and_loc,
  263.       or_loc;
  264. }
  265.  
  266. *-- @ SAY GETS Processing. -----------------------------------------------------
  267.  
  268. *--  Format Page: {page_cnt = 1
  269.                    page_cnt}
  270.  
  271. {line_cnt = wnd_cnt = 0
  272.  foreach ELEMENT k
  273.    color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  274.    if new_page(k) then
  275. }
  276. READ
  277.  
  278. *-- Format Page: {page_cnt}
  279.  
  280. {  endif
  281. //
  282.  
  283.    if ELEMENT_TYPE == @TEXT_ELEMENT or ELEMENT_TYPE == @FLD_ELEMENT then
  284.      if FLD_FIELDTYPE == calc then
  285. }
  286. *-- Calculated field: {cap_first(FLD_FIELDNAME)} - {FLD_DESCRIPT}
  287. {    endif
  288.      if FLD_FIELDTYPE == memvar then
  289. }
  290. *-- Memory variable: {cap_first(FLD_FIELDNAME)}
  291. {    endif}
  292. @ {nul2zero(ROW_POSITN) - line_cnt},{nul2zero(COL_POSITN)} \
  293. {  endif
  294.    if ELEMENT_TYPE == @BOX_ELEMENT then
  295. }
  296. @ {box_coordinates(k)}\
  297. {  endif}
  298. //
  299. {  case ELEMENT_TYPE of
  300.    @TEXT_ELEMENT:
  301.    // Certain control characters can cause dBASE problems ie, ASCII(13,26,0)
  302.    // so the form designer will either send them to us as a string if they are
  303.    // all the same character or as individual characters if they differ. We
  304.    // handle this by using the chr() function to "SAY" them in dBASE.
  305. }
  306. SAY \
  307. {     if asc(TEXT_ITEM) < 32 then
  308.         if len(TEXT_ITEM) == 1 then}
  309. CHR({asc(TEXT_ITEM)}) \
  310. {       else}
  311. REPLICATE(CHR({asc(TEXT_ITEM)}), {len(TEXT_ITEM)}) \
  312. {       endif
  313.       else
  314.          if substr(TEXT_ITEM,1,1) == "\"" then
  315.             // Double quote is being used on the design surface need to use
  316.             // brackets "[]" as delimiters
  317.             left_delimiter = "["
  318.             right_delimiter = "]"
  319.          endif
  320.          left_delimiter + TEXT_ITEM + right_delimiter} \
  321. {        left_delimiter = right_delimiter = "\""
  322.       endif
  323.       outcolor()}
  324. {  @Box_element:
  325.        outbox(BOX_TYPE, BOX_SPECIAL_CHAR)}
  326. {      outcolor()}
  327. {  @FLD_ELEMENT:
  328.       if !FLD_EDITABLE then; // its a SAY}
  329. SAY \
  330. {        if FLD_FIELDTYPE == calc then
  331.            // Loop thru expression in case it is longer than 237
  332.             foreach FLD_EXPRESSION fcursor in k
  333.                FLD_EXPRESSION}
  334. {           next}
  335. // Output a space after the Fld_expression and get ready for picture clause
  336.  \
  337. {        else // not a editable field
  338.             if FLD_FIELDTYPE == dbf then temp = "" else temp = "m->" endif
  339.                temp + cap_first(FLD_FIELDNAME)} \
  340. {        endif
  341.          if Ok_Template(k) then}
  342. PICTURE "{picture_for_say(k);}" \
  343. {        endif
  344.       else // it's a get}
  345. GET \
  346. {        if FLD_FIELDTYPE == dbf then 
  347.            temp = "" 
  348.            if !master_file then
  349.              master_file = FLD_FILENAME
  350.            endif
  351.          else 
  352.            temp = "m->" 
  353.          endif
  354.          temp + cap_first(FLD_FIELDNAME)} \
  355. {        if chr(FLD_VALUE_TYPE) == "M" && FLD_MEM_TYP then
  356.             if wnd_cnt < 20  then ++wnd_cnt endif
  357.             if Fld_mem_typ == 1}OPEN {endif}WINDOW wndow{wnd_cnt} \
  358. {        endif
  359.          if Ok_Template(k) then}
  360. PICTURE {picture_for_get(k);} \
  361. {        endif
  362.          if FLD_L_BOUND or FLD_U_BOUND then color_flg = 1;}
  363. ;
  364.    RANGE {if range_require & FLD_EDITABLE then}REQUIRED {endif}\
  365. {  FLD_L_BOUND}{if FLD_U_BOUND then},{FLD_U_BOUND}{endif} \
  366. {        endif
  367.          if FLD_OK_COND then color_flg = 1;}
  368. ;
  369. {           if at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" and
  370.                ok_coordinates( k, 2, 1, bad_pick ) then
  371.                // A POPUP is desired for showing coded values, redo the
  372.                // VALID clause to call a UDF based on "U_" + FLD_FIELDNAME
  373. }
  374.    VALID {    if valid_required & FLD_EDITABLE ||
  375.                  is_required( FLD_OK_COND )       then}REQUIRED {endif}\
  376. {  get_udfname(FLD_FIELDNAME)}( {cap_first(FLD_FIELDNAME)} ) \
  377. {             and_loc = at( ".AND.", upper(FLD_OK_COND) );
  378.               if and_loc > 0 then
  379.                 substr( FLD_OK_COND, and_loc )} \
  380. {             endif
  381.             else
  382.                 if !(at("POPUP", upper(ltrim(FLD_OK_COND))) == "2") then
  383. }
  384.    VALID {if valid_required & FLD_EDITABLE then}REQUIRED {endif}{FLD_OK_COND} \
  385. {
  386.                 endif
  387.             endif
  388.  
  389.             if FLD_REJ_MSG then}
  390. ;
  391.    ERROR \
  392. {              if !at("IIF", upper(FLD_REJ_MSG))}"{endif}{FLD_REJ_MSG}\
  393. {              if !at("IIF", upper(FLD_REJ_MSG))}"{endif} \
  394. {           endif
  395.          endif // FLD_OK_COND
  396.          if FLD_ED_COND then color_flg = 1;}
  397. ;
  398.    WHEN {FLD_ED_COND} \
  399. {
  400.          endif
  401.          if FLD_DEF_VAL then color_flg = 1;}
  402. ;
  403.    DEFAULT {FLD_DEF_VAL} \
  404. {        endif
  405.          if FLD_HLP_MSG then color_flg = 1;}
  406. ;
  407.    MESSAGE \
  408. {           if !at("IIF", upper(FLD_HLP_MSG))}"{endif}{FLD_HLP_MSG}\
  409. {           if !at("IIF", upper(FLD_HLP_MSG))}"{endif} \
  410. {        endif
  411.       endif // FLD_EDITABLE
  412. }
  413. {     outcolor()}
  414. {     color_flg = 0;
  415.    otherwise: goto getnext;
  416.    endcase
  417. }
  418.  
  419. //Leave the above blank line, it forces a line feed!
  420. //-----------------
  421. // End of @ SAY GET
  422. //-----------------
  423. {  ++cnt;
  424.    getnext:
  425.  next k
  426. return;
  427. // eof - fmt_file_body()
  428. enddef
  429.  
  430. //--------------------------------------------------------------
  431. define fmt_file_exit()
  432. }
  433. *-- Format file exit code -----------------------------------------------------
  434.  
  435. *-- SET STATUS was \
  436. {if dB_status then}
  437. ON when you went into the Forms Designer.
  438. IF lc_status = "OFF"  && Entered form with status off
  439.    SET STATUS OFF     && Turn STATUS "OFF" on the way out
  440. {else}
  441. OFF when you went into the Forms Designer.
  442. IF lc_status = "ON"  && Entered form with status on
  443.    SET STATUS ON     && Turn STATUS "ON" on the way out
  444. {endif}
  445. ENDIF
  446. {if carry_flg then}
  447. IF .NOT. ll_carry
  448.   SET CARRY OFF
  449. ENDIF
  450. {endif}
  451. IF .NOT. ll_cursor
  452.   SET CURSOR OFF
  453. ENDIF
  454. {if at("43", display_type()) then}
  455. SET DISPLAY TO &lc_display.      && Reset Screen size if changed
  456. {endif}
  457. {if wnd_names then}
  458.  
  459. RELEASE WINDOWS {substr(wnd_names, 1, (len(wnd_names) - 1))}
  460. {endif}
  461.  
  462. RELEASE {if carry_flg then}ll_carry,{endif}lc_fields,lc_status
  463. {    if is_help then}
  464.  
  465. ON KEY LABEL F1
  466. {    endif
  467.      if is_popup or is_help then}
  468. ON KEY LABEL F2
  469. {      if is_popup then}
  470. DO C_{procedure_name}{tabto(41)}&& Close up Lookup Files
  471. {      endif}
  472. SET PROCEDURE TO (lc_proc){tabto(41)}&& Re-Establish any open procedure file
  473. RELEASE lc_proc
  474. IF ll_talk
  475.   SET TALK ON
  476. ENDIF
  477. IF TYPE( "ll_echo" ) = "L"
  478.   IF ll_echo
  479.     SET ECHO ON
  480.   ENDIF
  481. ENDIF
  482. {    endif}
  483. *-- EOP: {filename(fmt_name)}FMT
  484. {return;
  485. // eof - fmt_file_exit()
  486. enddef
  487.  
  488. define picture_for_get(c)
  489. //--------------------------------------------------------------
  490. // DESCRIPTION
  491. //   Build a dBASE Picture template for a @ GET command
  492. //
  493. //--------------------------------------------------------------
  494.   if at("\"", c.FLD_TEMPLATE) or at("'", c.FLD_TEMPLATE)then
  495.     left_delimiter = "["
  496.     right_delimiter = "]";
  497.   endif
  498.   left_delimiter}
  499. { if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  500. {   if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  501.  {//leave this space}\
  502. { endif
  503.   if at("M", c.FLD_PICFUN) then
  504.     c.FLD_PIC_CHOICE}\
  505. { else
  506.     c.FLD_TEMPLATE}\
  507. { endif
  508.   right_delimiter}
  509. { left_delimiter = right_delimiter = "\""
  510.  return;
  511. enddef
  512.  
  513. //--------------------------------------------------------------
  514. define picture_for_say(c)
  515.      if c.FLD_PICFUN then}@{c.FLD_PICFUN}\
  516. {       if at("S", c.FLD_PICFUN) then}{c.FLD_PIC_SCROLL}{endif}\
  517.  {//leave this space}\
  518. {       endif
  519.      if !at("M", c.FLD_PICFUN) then
  520.         c.FLD_TEMPLATE}\
  521. {    endif
  522.  return;
  523. enddef
  524.  
  525. define make_pop_code()
  526. //--------------------------------------------------------------
  527. // Create the Procedure File for POPUP's if required
  528. //--------------------------------------------------------------
  529.   var lookup_dbf,   // store get_file(text_line1) for faster processing
  530.       look_alias,   // Lookup alias, diff from DBF if DBF starts with number
  531.       look_1st,     // 1st char of lookup DBF file
  532.       is_format,    // is there a format file
  533.       fmt_name,     // Name of the format file to use with browse
  534.       temp_name,    // store get_popname(text_line1)
  535.       prompt_field, // Name of field to build popup with
  536.       temp_key,
  537.       tag_name,     // tag name for the order
  538.       temp_org_file,// store get_org_file( text_line1 )
  539.       lookup_alias_on_form,
  540.       lookup_dbf_matches,
  541.       is_in_detail  // Flag for in a detail region
  542.       ;
  543.   if is_popup then
  544.     if !make_udf() then 
  545.       return 0;
  546.     endif
  547.     udf_header()
  548.  
  549. }
  550. PROCEDURE S_{procedure_name}
  551. *--------------------------------------------------------------------------------
  552. * DESCRIPTION
  553. *   Open data (.dbf) files for Lookup operations & faster processing
  554. *--------------------------------------------------------------------------------
  555.   PRIVATE lc_alias, ll_esc
  556.   ll_esc = SET( "ESCAPE" ) = "ON"
  557.   SET ESCAPE OFF
  558.   lc_alias = ALIAS(){tabto(41)}&& Capture current alias
  559.  
  560. {   foreach FLD_ELEMENT flds
  561.       at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0;
  562.       if at_pop then
  563.         lookup_dbf = Cap_first( get_file(FLD_OK_COND) );
  564.         look_1st = ASC( substr( lookup_dbf, 1, 1 ) );
  565.         look_alias = ( look_1st > 47 && look_1st < 58 ) ? 
  566.                         "A" + lookup_dbf : lookup_dbf;
  567.         tag_name = get_key(FLD_OK_COND);
  568.         prompt_field = get_field(FLD_OK_COND);
  569.         lookup_dbf_matches = (upper(lookup_dbf) == FLD_FILENAME) ?
  570.                                     TRUE : FALSE;
  571.         if not at("," + lookup_dbf, workarea_dbfs) then
  572.           workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  573. }
  574.   IF TYPE("g_{lower(lookup_dbf)}") = "U"
  575.     PUBLIC g_{lower(lookup_dbf)}
  576.  
  577.     IF SELECT("{lookup_dbf}") = 0
  578.       IF FILE( "{lookup_dbf}.DBF" )
  579.         SELECT SELECT()
  580.         USE {lookup_dbf} NOLOG ALIAS {look_alias}
  581.         g_{lower(lookup_dbf)} = 1{tabto(41)}&& File was opened for the first time
  582.         IF TAGNO( "{tag_name}" ) = 0
  583.           DO _Err_Box WITH [{tag_err} ] + [{tag_name}]
  584.           USE
  585.           RELEASE g_{lower(lookup_dbf)}
  586.           RELEASE gl_{lookup_dbf}
  587.           PUBLIC gl_{lookup_dbf}
  588.         ENDIF
  589.         IF TYPE( "{look_alias}->{prompt_field}" ) = "U"
  590.           DO _Err_Box WITH [{var_err} ] + [{look_alias}->{prompt_field}]
  591.           USE
  592.           RELEASE g_{lower(lookup_dbf)}
  593.           RELEASE gl_{lookup_dbf}
  594.           PUBLIC gl_{lookup_dbf}
  595.         ENDIF  
  596.       ELSE
  597.         DO _Err_Box WITH "{lookup_dbf}.DBF " + [{file_err}]
  598.         RELEASE g_{lower(lookup_dbf)}
  599.         RELEASE gl_{lookup_dbf}
  600.         PUBLIC gl_{lookup_dbf}
  601.       ENDIF
  602.     ELSE
  603.       g_{lower(lookup_dbf)} = 2{tabto(41)}&& File was opened outside of this program
  604.     ENDIF
  605.  
  606.   ELSE
  607.     *-- File was already opened by a program generated from Form.gen
  608.     g_{lower(lookup_dbf)} = g_{lower(lookup_dbf)} + 1
  609.   ENDIF
  610.  
  611. {       endif
  612.       endif
  613.     next;
  614. }
  615.   SELECT ( lc_alias )
  616.   IF ll_esc
  617.     SET ESCAPE ON
  618.   ENDIF
  619. RETURN
  620. *-- EOP: S_{procedure_name}
  621.  
  622.  
  623. PROCEDURE C_{procedure_name}
  624. *--------------------------------------------------------------------------------
  625. * DESCRIPTION
  626. *   Close Lookup files on exit of the .fmt, if they are not used
  627. *   by other calling .fmt files
  628. *--------------------------------------------------------------------------------
  629.   PRIVATE ll_esc
  630.   ll_esc = SET( "ESCAPE" ) = "ON"
  631.   SET ESCAPE OFF
  632. {   workarea_dbfs = ""
  633.     foreach FLD_ELEMENT flds
  634.       at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0;
  635.       if at_pop then
  636.         lookup_dbf = get_file(FLD_OK_COND)
  637.         look_1st = ASC( substr( lookup_dbf, 1, 1 ) );
  638.         look_alias = ( look_1st > 47 && look_1st < 58 ) ? 
  639.                         "A" + lookup_dbf : lookup_dbf;
  640.         if not at("," + lookup_dbf, workarea_dbfs) then
  641.           workarea_dbfs = workarea_dbfs + "," + lookup_dbf;
  642. }
  643.   DO CASE
  644.     CASE TYPE("g_{lower(lookup_dbf)}") = "U"
  645.       *-- Exiting out of the form!  Lookup file was not opened up properly
  646.       RELEASE gl_{lookup_dbf}
  647.     CASE g_{lower(lookup_dbf)} = 1
  648.       USE IN {look_alias}
  649.       RELEASE g_{lower(lookup_dbf)}
  650.     OTHERWISE
  651.       g_{lower(lookup_dbf)} = g_{lower(lookup_dbf)} - 1
  652.   ENDCASE
  653. {       endif
  654.       endif
  655.     next;
  656. }
  657.  
  658.   IF ll_esc
  659.     SET ESCAPE ON
  660.   ENDIF
  661. RETURN
  662. *-- EOP: C_{procedure_name}
  663.  
  664. {         line_cnt = lookup_cnt = 0
  665.           page_cnt = 1
  666.  
  667.           foreach FLD_ELEMENT flds
  668.  
  669.                at_pop = at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" ? 1 : 0;
  670.  
  671.                new_page(flds)
  672.                if at_pop then
  673.                     trow_positn = nul2zero(ROW_POSITN) - line_cnt
  674.                     tcol_positn = nul2zero(COL_POSITN)
  675.                     lookup_dbf = get_file(FLD_OK_COND);
  676.                     look_1st = ASC( substr( lookup_dbf, 1, 1 ) );
  677.                     look_alias = ( look_1st > 47 && look_1st < 58 ) ? 
  678.                                  "A" + lookup_dbf : lookup_dbf;
  679.                     tag_name = get_key(FLD_OK_COND);
  680.                     prompt_field = get_field(FLD_OK_COND);
  681.                     color = getcolor(FLD_DISPLAY, FLD_EDITABLE) // get color of element
  682.  
  683.                     if !ok_coordinates(flds, 2, 0, "") then 
  684.                       loop 
  685.                     endif
  686. }
  687. FUNCTION {get_udfname(FLD_FIELDNAME)}
  688. PARAMETER fld_name
  689. *{replicate("-",69)}
  690.   PRIVATE ALL LIKE l?_*
  691.   PRIVATE esckey, fld_name, rtn_fld
  692.   ll_esc = SET( "ESCAPE" ) = "ON"
  693.   SET ESCAPE OFF
  694.   ll_return = .F.
  695.   IF TYPE( "gl_{lookup_dbf}" ) = "L"{tabto(41)}&& Was lookup file opened?
  696.     IF ll_esc{tabto(41)}&& It wasn't, so return back to the form
  697.       SET ESCAPE ON
  698.     ENDIF
  699.     RETURN(.T.){tabto(41)}&& With no data validation
  700.   ENDIF
  701. {                   if !is_required(FLD_OK_COND) then}
  702.   IF ISBLANK(fld_name){tabto(41)}&& Not a required field
  703.     IF ll_esc
  704.       SET ESCAPE ON
  705.     ENDIF
  706.     RETURN (.T.){tabto(41)}&& Return since it's a blank field
  707.   ENDIF
  708.  
  709. {                    endif}
  710.   EscKey = 27{tabto(41)}&& 27 represents the ESC key
  711.  
  712.   lc_alias = ALIAS(){tabto(41)}&& Grab current workarea
  713.   SELECT {look_alias}{tabto(41)}&& Select the lookup file
  714.   lc_order = ORDER(){tabto(41)}&& Save any existing order
  715.   SET ORDER TO {tag_name}{tabto(41)}&& Set the order to the lookup key
  716.  
  717.   ll_exact = SET("EXACT") = "ON"{tabto(41)}&& Store value of EXACT
  718.   SET EXACT ON
  719.  
  720. {                   if chr(FLD_VALUE_TYPE) == "C" then}
  721.   fld_name = IIF( ISBLANK( TRIM( fld_name)), fld_name, TRIM( fld_name))
  722. {                   endif}
  723.   SEEK fld_name
  724.  
  725.   IF .NOT. ll_exact{tabto(41)}&& Restore SET EXACT to org. value
  726.     SET EXACT OFF
  727.   ENDIF
  728.  
  729.   IF .NOT. FOUND()
  730.  
  731.     DEFINE POPUP {get_popname(FLD_OK_COND)} FROM \
  732. {         if trow_positn < max_pop_row then
  733.              trow_positn + 1},{tcol_positn} ;
  734.         TO {scrn_size-1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  735. {         else
  736.              trow_positn - 11},{tcol_positn} ;
  737.         TO {trow_positn - 1},{tcol_positn + len(FLD_TEMPLATE) + 1} ;
  738. {         endif}
  739.         PROMPT FIELD {prompt_field} ;
  740.         MESSAGE {select_msg1}
  741.  
  742.     ON SELECTION POPUP {get_popname(FLD_OK_COND)} DEACTIVATE POPUP
  743.  
  744. {                        if chr(FLD_VALUE_TYPE) == "C" then}
  745.     KEYBOARD TRIM(fld_name)
  746. {                   endif}
  747.     SAVE SCREEN TO temp
  748. {                   if is_shadow(FLD_OK_COND) and
  749.                        ok_coordinates( flds, 4, 1, bad_shadow ) then
  750. }
  751.     DO shadowg WITH {get_pop_shadow(FLD_TEMPLATE);}
  752.  
  753. {                   endif
  754. }
  755.     ACTIVATE POPUP {get_popname(FLD_OK_COND)}
  756.  
  757.     rtn_fld = PROMPT(){tabto(41)}&& Get user choice from pick list
  758.     ln_bar = BAR(){tabto(41)}&& Capture bar number to check for esc
  759.  
  760.     RELEASE POPUP {get_popname(FLD_OK_COND)}
  761.  
  762.     RESTORE SCREEN FROM temp
  763.  
  764.     IF ln_bar <> 0
  765.       @ {trow_positn},{tcol_positn} GET rtn_fld \
  766. {        if Ok_Template(flds) then}
  767. PICTURE {picture_for_get(flds);} \
  768. {           outcolor()}
  769. {        endif}
  770.  
  771.       CLEAR GETS
  772.  
  773.       REPLACE {cap_first(FLD_FILENAME)}->{cap_first(FLD_FIELDNAME)} WITH \
  774. {        if chr(FLD_VALUE_TYPE) == "C" then}
  775. rtn_fld
  776. {        else}
  777. VAL(rtn_fld)
  778. {        endif}
  779.  
  780.       ll_return = .T.
  781.     ELSE
  782.       ll_return = .F.
  783. {
  784.                     if !is_required(FLD_OK_COND) then
  785. }
  786.       IF ISBLANK(fld_name){tabto(41)}&& Not a required field, so return
  787.         ll_return = .T.
  788.       ENDIF
  789.  
  790. {
  791.                     endif
  792. }
  793.     ENDIF
  794.  
  795.   ELSE
  796.     ll_return = .T.
  797.   ENDIF
  798.  
  799.   IF .NOT. ISBLANK( lc_order ){tabto(41)}&& If there was a order on lookup file
  800.     SET ORDER TO ( lc_order ){tabto(41)}&& Set it back to its original setting
  801.   ENDIF
  802.  
  803.   SELECT (lc_alias){tabto(41)}&& Go back to the edit file
  804.  
  805.   IF ll_esc
  806.     SET ESCAPE ON
  807.   ENDIF
  808. RETURN (ll_return)
  809. *-- EOP: {get_udfname(FLD_FIELDNAME)}
  810.  
  811. {
  812.                endif
  813.           next flds
  814.           print("*"+replicate("-",78)+crlf);}
  815.  
  816. {    endif
  817.      return;
  818. // eof - make_pop_code()
  819. enddef
  820.  
  821. //--------------------------------------------------------------
  822. define make_help_code()
  823. //------------------------------------
  824. // Make procedures for the help system
  825. //------------------------------------
  826. if is_help then
  827.      // If the udf file has not already been created, make it.
  828.     if not udf_file then
  829.        if !make_udf() then 
  830.            return 0;
  831.        endif
  832.        // Put up the UDF header
  833.        udf_header()
  834.     endif
  835.     // Make procedures for the help system
  836.     make_help()
  837. endif
  838. if is_help or is_popup then
  839.    // Make shadow procedures
  840.    make_shadow_procs()
  841. endif
  842. return;
  843. enddef
  844.  
  845. //--------------------------------------------------------------
  846. define header()
  847. // Print Header in program
  848.   var len_filename,
  849.       file_name;
  850.  
  851.   file_name = filename(fmt_name);
  852.   len_filename = len( file_name );
  853.   if substr( file_name, len_filename, 1 ) == "." then
  854.     file_name = substr( file_name, 1, len_filename - 1 ) + ".FMT";
  855.   else
  856.     file_name = file_name + ".FMT";
  857.   endif
  858. }
  859. *{replicate( "-", 69)}
  860. * Name.......: {file_name}
  861. * Date.......: {ltrim( substr( date(),1,8))}
  862. * Version....: dBASE IV, Format {db_version_no}
  863. * Notes......: Format files use "" as delimiters!
  864. *{replicate( "-", 69)}
  865. {
  866. enddef
  867.  
  868. //--------------------------------------------------------------
  869. define udf_header()
  870. // Print Header in UDF program
  871.   var len_filename,
  872.       file_name;
  873.  
  874.   file_name = filename(fmt_name);
  875.   len_filename = len( file_name );
  876.   if substr( file_name, len_filename, 1 ) == "." then
  877.     file_name = substr( file_name, 1, len_filename - 1 ) + ".FMT";
  878.   else
  879.     file_name = file_name + ".FMT";
  880.   endif
  881. }
  882. *{replicate( "-", 69)}
  883. * Name....: U_{rtrim(substr(name,1,6))}.PRG
  884. * Date....: {ltrim(SUBSTR(date(),1,8))}
  885. * Version.: dBASE IV, Procedure for Format {db_version_no}
  886. * Notes...: Procedure file for VALID POPUPs and/or Context Sensitive Help
  887. *           for {file_name}
  888. { if master_file then}
  889. *           The Master file for the form is assumed to be {master_file}.
  890. { endif}
  891. *{replicate( "-", 69)}
  892. { lmarg(offset)}
  893. PRIVATE ll_oldtalk
  894. IF SET( "TALK" ) = "ON"
  895.   SET TALK OFF
  896.   ll_oldtalk = .T.
  897. ELSE
  898.   ll_oldtalk = .F.
  899. ENDIF
  900.  
  901. *-- {can_not_run}
  902. DO _Err_Box WITH "{can_not_run}"
  903.  
  904. IF ll_oldtalk
  905.   SET TALK ON
  906. ENDIF
  907. {   lmarg(0)}
  908. RETURN
  909.  
  910.  
  911. {
  912. enddef
  913.  
  914. //--------------------------------------------------------------
  915. define ok_template(cur)
  916.      if cur.FLD_TEMPLATE && !(chr(cur.FLD_VALUE_TYPE) == "D" ||
  917.                               chr(cur.FLD_VALUE_TYPE) == "M") then
  918.         return 1;
  919.      else
  920.         return 0;
  921.      endif
  922. enddef
  923.  
  924. //--------------------------------------------------------------
  925. define ok_coordinates(cur,              // Current cursor
  926.                       xtra_width,       // Additional width to check ie, shadow
  927.                       want_message,     // Display message flag 0:No 1:Yes
  928.                       message)          // Message to display to user
  929.      // Check to see if coordinates of popup or shadow will fit on screen
  930.      // based on the dimensions of the current field
  931.      if nul2zero(cur.COL_POSITN) + len(cur.FLD_TEMPLATE) + xtra_width > 80 then
  932.         if want_message then
  933.            beep(2)                      // UDF in builtin.def
  934.            cls()
  935.            say_center(10,"Error on Field: " + cur.FLD_FIELDNAME)
  936.            say_center(12, message)
  937.            pause(any_key)
  938.         endif
  939.         return 0;
  940.      else
  941.         return 1;
  942.      endif
  943. enddef
  944.  
  945. //--------------------------------------------------------------
  946. define screen_size()
  947.    // Test screen size if display > 2 screen is 43 lines
  948.    display = numset(_flgcolor)
  949.    if display > ega25 then
  950.        scrn_size = 39
  951.        max_pop_row = 36
  952.    else
  953.        max_pop_row = 18
  954.        scrn_size = 21
  955.    endif
  956.  
  957.    // Test to see if status was off before going into form designer
  958.    dB_status = numset(_flgstatus)
  959.    if scrn_size == 21 and !db_status then
  960.       scrn_size = 24
  961.       max_pop_row = 21
  962.    endif
  963.    if scrn_size == 39 and !db_status then // status is off
  964.       scrn_size = 42
  965.       max_pop_row = 39
  966.    endif
  967.    return;
  968. enddef
  969.  
  970. //--------------------------------------------------------------
  971. define display_type()
  972.     // Find out the display type we are working on
  973.     var temp;
  974.     case display of
  975.        mono:   temp = "MONO"
  976.        cga:    temp = "COLOR"
  977.        ega25:  temp = "EGA25"
  978.        mono43: temp = "MONO43"
  979.        ega43:  temp = "EGA43"
  980.      endcase
  981.      return temp;
  982. enddef
  983.  
  984. //--------------------------------------------------------------
  985. define getcolor(f_display,         // Color of the current field
  986.                 f_editable         // Field is SAY or GET
  987.                )
  988.  // Determines the color from f_display and f_editable (GET or SAY)
  989.  enum  Foreground  =   7,
  990.        Intensity   =   8,  // Color
  991.        Background  = 112,
  992.        MIntensity  = 256,
  993.        Reverse     = 512,  // Mono
  994.        Underline   =1024,
  995.        Blink       =2048,
  996.        default     =32768; // Screen set to default
  997.  
  998.  var forgrnd, enhanced, backgrnd, blnk, underln, revrse, use_colors, incolor;
  999.  incolor=""
  1000.  
  1001.  use_colors  = default & f_display
  1002.  forgrnd  = Foreground & f_display
  1003.  enhanced = (Intensity & f_display) || (MIntensity & f_display)
  1004.  backgrnd = Background & f_display
  1005.  blnk     = Blink  & f_display
  1006.  underln  = Underline & f_display
  1007.  revrse   = Reverse & f_display
  1008.  
  1009.  if not use_colors then // Use system colors, no colors set in designer
  1010.  
  1011.     if backgrnd then backgrnd = backgrnd/16 endif
  1012.  
  1013.     if (display != mono and display != mono43) then
  1014.        case forgrnd of
  1015.         0: incolor = "n"
  1016.         1: incolor = "b"
  1017.         2: incolor = "g"
  1018.         3: incolor = "bg"
  1019.         4: incolor = "r"
  1020.         5: incolor = "rb"
  1021.         6: incolor = "gr"
  1022.         7: incolor = "w"
  1023.        endcase
  1024.     else
  1025.        incolor = "w"
  1026.     endif
  1027.  
  1028.     if revrse then
  1029.        incolor = incolor + "i"
  1030.     endif
  1031.     if underln then
  1032.        incolor = incolor + "u"
  1033.     endif
  1034.     if enhanced then
  1035.        incolor = incolor + "+"
  1036.     endif
  1037.     if blnk then
  1038.        incolor = incolor + "*"
  1039.     endif
  1040.  
  1041.     incolor = incolor + "/"
  1042.  
  1043.     if (display != mono and display != mono43) then
  1044.        case backgrnd of
  1045.         0: incolor = incolor + "n"
  1046.         1: incolor = incolor + "b"
  1047.         2: incolor = incolor + "g"
  1048.         3: incolor = incolor + "bg"
  1049.         4: incolor = incolor + "r"
  1050.         5: incolor = incolor + "rb"
  1051.         6: incolor = incolor + "gr"
  1052.         7: incolor = incolor + "w"
  1053.        endcase
  1054.     else
  1055.        incolor = incolor + "n"
  1056.     endif
  1057.  
  1058.     if f_editable and incolor then
  1059.        incolor = incolor + "," + incolor
  1060.     endif
  1061.  
  1062.  endif // use no colors
  1063.  return alltrim(incolor);
  1064. enddef
  1065.  
  1066. //--------------------------------------------------------------
  1067. define outbox(mbox,            // Border type
  1068.               mchar            // Special character of border
  1069.              )
  1070.    // Output the of Box border and character if any
  1071.    var result;
  1072.    case mbox of
  1073.       0: result = " " // single
  1074.       1: result = " DOUBLE "
  1075.       2: result = " CHR("+mchar+") "
  1076.    endcase
  1077.    return result;
  1078. enddef
  1079.  
  1080. //--------------------------------------------------------------
  1081. define outcolor()
  1082.   // Output the of color of the @ SAY GET or Box
  1083.   var result;
  1084.   result = "";
  1085.   if len(color) > 0 then
  1086.      if color_flg then
  1087.         // If flag is set output a dBASE continuation ";"
  1088.         result = ";" + crlf + space(3)
  1089.      endif
  1090.      result = result + "COLOR " + color + " "
  1091.   endif
  1092.   return result;
  1093. enddef
  1094.  
  1095. //--------------------------------------------------------------
  1096. define window_def(cur)
  1097.    // Build dBASE window command
  1098.    var result;
  1099.    result = "wndow" + wnd_cnt + " FROM " + Box_Coordinates(cur);
  1100.    result = result + outbox(cur.BOX_TYPE, cur.BOX_SPECIAL_CHAR);
  1101.    color = getcolor(cur.FLD_DISPLAY, cur.FLD_EDITABLE);
  1102.    result = result + outcolor();
  1103.    return result;
  1104. enddef
  1105.  
  1106. //--------------------------------------------------------------
  1107. define box_coordinates(cur)             // Pass in foreach cursor
  1108. //
  1109. // Build box coordinates for a dBASE window command
  1110. //
  1111.   var result, temp_page, line_cnt, cur_box_top, cur_row_positn,
  1112.       scrn_num4_win, scrn_num4_fld, cur_box_left;
  1113.  
  1114.   cur_box_top    = nul2zero(cur.BOX_TOP);
  1115.   cur_row_positn = nul2zero(cur.ROW_POSITN);
  1116.   cur_box_left   = nul2zero(cur.BOX_LEFT);
  1117.   
  1118.   if cur.FLD_MEM_TYP then                   // If MEMO window
  1119.     scrn_num4_win = cur_box_top / scrn_size;
  1120.     scrn_num4_fld = cur_row_positn / scrn_size;
  1121.     if scrn_num4_win != scrn_num4_fld then  // If window not on same screen
  1122.       cur_box_top = ( cur_box_top % scrn_size ) + scrn_size + 1;
  1123.     endif
  1124.   endif
  1125.  
  1126.   temp_page = cur_box_top / scrn_size;
  1127.   line_cnt = (scrn_size * temp_page) + (1 * temp_page);
  1128.  
  1129.   result = cur_box_top - line_cnt +",";
  1130.   result = result + cur_box_left + " TO ";
  1131.   temp = cur_box_top + cur.BOX_HEIGHT - line_cnt - 1;
  1132.   if temp > scrn_size then
  1133.     temp = scrn_size;
  1134.   endif
  1135.   result = result + temp + "," + ( cur_box_left + cur.BOX_WIDTH - 1 );
  1136.   return result;
  1137. enddef
  1138.  
  1139.  
  1140. //--------------------------------------------------------------
  1141. define carry_flds()
  1142.    // Build dBASE SET CARRY command
  1143.    carry_len = carry_lent = 13
  1144.    carry_first = 0
  1145.    foreach FLD_ELEMENT flds
  1146.       if FLD_CARRY then
  1147.          carry_len = carry_len + len(FLD_FIELDNAME + ",")
  1148.          carry_lent = carry_lent + len(FLD_FIELDNAME + ",")
  1149.          if carry_lent > 1000 then
  1150.             print(crlf + "SET CARRY TO ")
  1151.             carry_len = carry_lent = 13
  1152.          endif
  1153.          if carry_len > 75 then print(";" + crlf + "  ")  carry_len = 2 endif
  1154.          temp = cap_first(FLD_FIELDNAME)
  1155.          if !carry_first then
  1156.             print(temp)
  1157.             carry_first = 1
  1158.          else
  1159.             print("," + temp)
  1160.          endif
  1161.       endif
  1162.     next flds
  1163.     print(" ADDITIVE");
  1164.  return;
  1165. enddef
  1166.  
  1167. //--------------------------------------------------------------
  1168.  
  1169. define make_fmt()
  1170.    // Attempt to create program (fmt) file.
  1171.    default_drv = strset(_defdrive)  // grab default drive from dBASE
  1172.    fmt_name = FRAME_PATH + NAME     // Put path on to object name
  1173.    if not fileok(fmt_name) then
  1174.       if !default_drv then
  1175.          fmt_name = NAME
  1176.       else
  1177.          fmt_name = default_drv + ":" + NAME
  1178.       endif
  1179.    endif
  1180.    fmt_name = upper(fmt_name)
  1181.    if not create(fmt_name+".FMT") then
  1182.         pause(fileroot(fmt_name) +".FMT" + read_only + any_key)
  1183.         return 0;
  1184.      endif
  1185.    return 1;
  1186. enddef
  1187. //--------------------------------------------------------------
  1188.  
  1189. define make_udf()
  1190.    // Attempt to create dBASE procedure (prg) file.
  1191.    var udf_root_file_name;
  1192.    udf_root_file_name =  frame_path + "u_" + rtrim(substr(name,1,6))
  1193.    if not create( udf_root_file_name + ".PRG") then
  1194.       pause(udf_root_file_name + ".PRG" + read_only + any_key)
  1195.       return 0;
  1196.    endif
  1197.    // Force dBASE to recompile the .prg
  1198.    fileerase(udf_root_file_name + ".DBO")
  1199.    udf_file = 1 // Global flag to determine if UDF file was created
  1200.    return 1;
  1201. enddef
  1202.  
  1203. //--------------------------------------------------------------
  1204. define check_for_popups()
  1205. // Check for "popup" string for this fmt file
  1206. foreach FLD_ELEMENT flds
  1207.     if at("POPUP", upper(ltrim(FLD_OK_COND))) == "2" then
  1208.        is_popup = 1
  1209.        exit
  1210.     endif
  1211. next flds
  1212. return is_popup;
  1213. enddef
  1214.  
  1215. //--------------------------------------------------------------
  1216. define check_for_help()
  1217.    // Check for help support for this fmt file
  1218.    // Looking for a .dBF with the same name as the .fmt file
  1219.    hlp_name = frame_path + substr(fileroot(fmt_name), 1, 6) + "_H"
  1220.  
  1221.    if fileexist(hlp_name + ".DBF") and fileexist(hlp_name + ".DBT") then
  1222.       is_help = 1      // Global flag for help support
  1223.    endif
  1224. return is_help;
  1225. enddef
  1226.  
  1227. define new_page(cur)               // Pass in foreach cursor
  1228. //----------------------------------------------------------------------
  1229. // NAME
  1230. //   New_Page - Check for a page break and adjusts line_cnt and page_cnt
  1231. //
  1232. // DESCRIPTION
  1233. //   New_Page() will determine the top line on the screen for the
  1234. //   object specified by the cursor <cur> and is assigned to the
  1235. //   global variable, <line_cnt>.  If the object is on a new page, 
  1236. //   the global variable, <page_cnt>, is adjusted to the new page.
  1237. //   
  1238. //   New_Page() will return a TRUE value if a page break occured, 
  1239. //   otherwise it will return a FALSE value.
  1240. //   
  1241. // EXAMPLE
  1242. //     foreach ELEMENT k
  1243. //       if new_page( k )
  1244. //         ... page break occured
  1245. //       endif
  1246. //     next k;
  1247. //
  1248. // GLOBAL VARIABLES
  1249. //   line_cnt = line number for the top line on the given page
  1250. //   page_cnt = page number for the object, starting at 1
  1251. //
  1252. //----------------------------------------------------------------------
  1253.   var cur_row_positn, 
  1254.       temp_page;
  1255.  
  1256.   cur_row_positn = nul2zero( cur.ROW_POSITN )
  1257.  
  1258.   if cur_row_positn - line_cnt > scrn_size then
  1259.     temp_page = cur_row_positn / scrn_size
  1260.     line_cnt = (scrn_size * temp_page) + (1 * temp_page)
  1261.     page_cnt = temp_page + 1
  1262.     return TRUE;
  1263.   endif
  1264. return FALSE;
  1265. enddef
  1266.  
  1267. //--------------------------------------------------------------
  1268. define parse_line( before,         // Out: chars before the look_for string
  1269.                    input,          // In:  line being parsed
  1270.                    look_for        // In:  string searched for
  1271.                  )                 // Rtn: chars after the look_for string
  1272. // If the look_for sting is not found, the before sting will equal the
  1273. // input string, and the returned value will be NUL
  1274.      var location;
  1275.  
  1276.      location = at(look_for, UPPER(input))
  1277.      if location == 0 then
  1278.           before = input
  1279.           return ( "" );
  1280.      endif
  1281.  
  1282.      before = substr( input, 1, location-1)
  1283.      return ( substr( input,
  1284.                       location+len(look_for),
  1285.                       len(input)
  1286.                     )
  1287.             );
  1288.  
  1289. // end: parse_line()
  1290. enddef
  1291.  
  1292. //--------------------------------------------------------------
  1293. // Parsing routines for pulling objects out of the VALID string
  1294. // "POPUP" = "file->fld_name ORDER key_fld REQ"
  1295. // 1234567890123456789012345678901234567890123
  1296. //            1         2         3         4
  1297. define get_file(valid_str)
  1298.      var  s_arrow,            // String "->"
  1299.           test,
  1300.           s_equal,            // String "="
  1301.           next_alpha,
  1302.           at_alias,
  1303.           s_before,           // String before the searched for item
  1304.           r_target,           // Remainder of the target string after item
  1305.           use_name;           // Return for file
  1306.  
  1307.      s_arrow = "->"
  1308.      s_equal = "="
  1309.      r_target = parse_line( s_before, valid_str, s_equal )      // ' "file->...'
  1310.      next_alpha = atalpha(r_target)                             // 3
  1311.      at_alias = at(s_arrow, r_target)                           // 7
  1312.      use_name = substr(r_target,next_alpha,at_alias-next_alpha) // 'file'
  1313.  
  1314.      return cap_first(use_name);
  1315. enddef
  1316.  
  1317. //--------------------------------------------------------------
  1318. define get_key(valid_str)
  1319.      var  s_order,            // String "ORDER "
  1320.           at_space,
  1321.           q_space,
  1322.           s_before,           // String before the searched for item
  1323.           r_target,           // Remainder of the target string after item
  1324.           order_tag;          // Search TAG to ORDER BY
  1325.  
  1326.      s_order = "ORDER "
  1327.      r_target = parse_line( s_before, valid_str, s_order ) // 'key_fld REQ'
  1328.      at_space = at(" ",r_target)
  1329.      if at_space == 0 then
  1330.           order_tag = substr(r_target, 1, len(r_target)-1) // 'key_fld"'
  1331.      else
  1332.           q_space = at('"',r_target)
  1333.           if q_space != 0 && q_space < at_space then
  1334.                order_tag = substr(r_target, 1, q_space-1)
  1335.           else
  1336.                order_tag = substr(r_target, 1, at_space-1)
  1337.           endif
  1338.      endif
  1339.      return cap_first(order_tag);
  1340. enddef
  1341.  
  1342. //--------------------------------------------------------------
  1343. define get_field(valid_str)
  1344.      var  s_arrow,            // String "->"
  1345.           at_space,
  1346.           s_before,           // String before the searched for item
  1347.           r_target,           // Remainder of the target string after item
  1348.           fld_name;           // Field name to lookup in target file
  1349.  
  1350.      s_arrow = "->"
  1351.      r_target = parse_line( s_before,
  1352.                             valid_str, s_arrow ) // 'fld_name ORDER...'
  1353.      at_space = at(" ",r_target)
  1354.  
  1355.      fld_name = ( at_space == 0 ? r_target : substr(r_target, 1, at_space-1) );
  1356.  
  1357.      return cap_first(fld_name);
  1358. enddef
  1359.  
  1360. //--------------------------------------------------------------
  1361. define get_popname(valid_str)
  1362.      // Create popup name
  1363.      return ( lower( "u_" + substr( get_field( valid_str),1,6) ) );
  1364. enddef
  1365.  
  1366. //--------------------------------------------------------------
  1367. define get_pop_shadow(field_template)   // Pass in FLD_TEMPLATE to deter. shadow
  1368.      if trow_positn < max_pop_row then
  1369.         trow_positn + 1},{tcol_positn},{scrn_size-1},{tcol_positn+len(Field_template)+1}
  1370. {    else
  1371.         trow_positn - 11},{tcol_positn},{trow_positn - 1},{tcol_positn+len(Field_template)+1}
  1372. {    endif
  1373.      return;
  1374. enddef
  1375.  
  1376. //---------------------------------------------------------------
  1377. define get_udfname(fld_str)
  1378.      // Create UDF name
  1379.      return cap_first( "u_" + substr( fld_str,1,6) );
  1380. enddef
  1381.  
  1382. //--------------------------------------------------------------
  1383. define is_required(valid_str)
  1384.      // Determines if the field is required before moving to the next field
  1385.      return ( ( at(" REQ ",  upper(valid_str)) ? 1 : 0 ) or 
  1386.               ( at(" REQ\"", upper(valid_str)) ? 1 : 0 )
  1387.             );
  1388. enddef
  1389.  
  1390. //--------------------------------------------------------------
  1391. define is_shadow(valid_str)
  1392.      // Determines if the user wants shadowing for popup
  1393.      return ( ( at(" SHADOW ",  upper(valid_str)) ? 1 : 0 ) or 
  1394.               ( at(" SHADOW\"", upper(valid_str)) ? 1 : 0 )
  1395.             );
  1396. enddef
  1397.  
  1398. //--------------------------------------------------------------
  1399. define make_shadow_procs()
  1400.      // Make the dBASE code for shadowing
  1401. }
  1402. PROCEDURE Shadowg
  1403. *{replicate("-",69)}
  1404. * DESCRIPTION
  1405. *   Displays shadow that grows.  Specify the same coord and the
  1406. *   window or popup to shadow.
  1407. *{replicate("-",69)}
  1408.   PARAMETER x1,y1,x2,y2
  1409.   PRIVATE   x1,y1,x2,y2
  1410.  
  1411.   x0 = x2+1
  1412.   y0 = y2+2
  1413.   dx = 1
  1414.   dy = (y2-y1) / (x2-x1)
  1415.   DO WHILE x0 <> x1 .OR. y0 <> y1+2
  1416.     @ x0,y0 FILL TO x2+1,y2+2 COLOR n+/n
  1417.     x0 = IIF(x0<>x1,x0 - dx,x0)
  1418.     y0 = IIF(y0<>y1+2,y0 - dy,y0)
  1419.     y0 = IIF(y0<y1+2,y1+2,y0)
  1420.   ENDDO
  1421.  
  1422. RETURN
  1423. *-- EOP: shadowg
  1424.  
  1425. {    return;
  1426. enddef
  1427.  
  1428.  
  1429. define make_general_procs()
  1430. //--------------------------------------------------------------
  1431. // Make the dBASE core routines
  1432. //--------------------------------------------------------------
  1433. }
  1434. PROCEDURE _Err_Box
  1435. PARAMETERS pc_msg
  1436. *----------------------------------------------------------------------------
  1437. * NAME
  1438. *   _Err_Box - Display an error box
  1439. *
  1440. * SYNOPSIS
  1441. *   DO _Err_Box WITH <pc_msg>
  1442. *
  1443. * DESCRIPTION
  1444. *   _Err_Box will display the <pc_msg> string in a box and prompt the
  1445. *   user to press any key to continue processing.  _Err_Box will display
  1446. *   the message based on the length of <pc_msg>.
  1447. *
  1448. * PARAMETERS
  1449. *   pc_msg - the error message to display in the box.  If the length is
  1450. *            greater than 76, the trailing part is chopped off.
  1451. *
  1452. * EXAMPLE
  1453. *   DO _Err_Box WITH "Incorrect window size"
  1454. *   Displays the message in a window as follows at row 9 on the screen:
  1455. *                      +------------------------------+
  1456. *                      |                              |
  1457. *                      |    Incorrect window size     |
  1458. *                      |                              |
  1459. *                      | Press any key to continue... |
  1460. *                      |                              |
  1461. *                      +------------------------------+
  1462. *   Note that the width of the window will increase to accommodate a longer
  1463. *   message string.
  1464. *
  1465. * LIMITATIONS
  1466. *   Truncates the message after 76 characters.  Assumes an 80 character
  1467. *   wide screen.  Looks best with SET CURSOR OFF.
  1468. *
  1469. *----------------------------------------------------------------------------
  1470.  
  1471.   PRIVATE lc_anykey, lc_msg, lc_msglen, lc_win, ln_press, ln_width, ll_trap,;
  1472.           ll_escape
  1473.  
  1474.   lc_anykey = [Press any key to continue...]
  1475.   ln_press  = LEN( lc_anykey )
  1476.   lc_win = WINDOW()                     && Currently activated window if any
  1477.   lc_msg = LTRIM( RTRIM( pc_msg ) )     && Trimmed message
  1478.   ln_msglen = LEN( lc_msg )             && Trimmed length of message
  1479.   ln_width = 0                          && Width of display area in window.
  1480.   ll_escape = SET("ESCAPE") = "ON"
  1481.   IF TYPE( "FXL_DEV" ) = "L" .AND. FXL_DEV
  1482.     SET ESCAPE ON
  1483.   ELSE
  1484.     SET ESCAPE OFF
  1485.   ENDIF
  1486.  
  1487.   *-- Determine the width needed for the window:
  1488.   IF ln_msglen <= ln_press
  1489.     ln_width = ln_press
  1490.   ELSE
  1491.     *-- Make sure the message fits in the window:
  1492.     IF ln_msglen > 76
  1493.       lc_msg = LEFT( lc_msg, 76 )
  1494.       ln_msglen = 76
  1495.     ENDIF
  1496.     ln_width = ln_msglen
  1497.   ENDIF
  1498.   DEFINE WINDOW _err_box FROM 9, ((76 - ln_width) + .5) / 2 ;
  1499.                 TO 15, (ln_width + 83) / 2 DOUBLE
  1500.   ln_width = ( ln_width + 2 )
  1501.  
  1502.   *-- Display the message and prompt to the window and wait for a key press
  1503.   ACTIVATE WINDOW _err_box
  1504.   @ 1, ( ln_width - ln_msglen ) / 2 SAY lc_msg
  1505.   @ 3, ( ln_width - ln_press ) / 2 SAY lc_anykey
  1506.   SET CONSOLE OFF                       && For mouse click recognition
  1507.   WAIT
  1508.   SET CONSOLE ON
  1509.  
  1510.   *-- Clean up the window display and reactivate the previous window
  1511.   RELEASE WINDOW _err_box
  1512.   IF ISBLANK( lc_win )
  1513.     ACTIVATE SCREEN
  1514.   ENDIF
  1515.  
  1516.   IF ll_escape
  1517.     SET ESCAPE ON
  1518.   ELSE
  1519.     SET ESCAPE OFF
  1520.   ENDIF
  1521.  
  1522. RETURN
  1523. *-- EOP: _Err_Box WITH pc_msg
  1524.  
  1525.  
  1526. FUNCTION _Rat
  1527. PARAMETERS pc_source, pc_target
  1528. *--------------------------------------------------------------------
  1529. * NAME
  1530. *   _RAT - Version of AT() that starts from right.
  1531. *
  1532. * SYNOPSIS
  1533. *   _RAT( <expC>, <expC> )
  1534. *
  1535. * DESCRIPTION
  1536. *   _RAT() takes two arguments, a source string and a target
  1537. *   string.  It searches for the first occurrence of the source
  1538. *   within the target beginning on the right end of the string,
  1539. *   and returns an integer representing the first character
  1540. *   position of the matching occurrence.
  1541. *
  1542. *   If the source string is not contained within the target
  1543. *   string, if the source string is longer than the target
  1544. *   string, or if the source string is null, 0 is returned.
  1545. *
  1546. * PARAMETER(S)
  1547. *   The first parameter is the string to find.  The second
  1548. *   parameter is the string to search in.  In theory, any
  1549. *   character expression should be legal.
  1550. *
  1551. * EXAMPLE(S)
  1552. *
  1553. *   ? _RAT("A","ABABA")                      && Returns 5
  1554. *   lc_var = _RAT("A test","A test A test")  && Returns 8
  1555. *   ? _RAT("Long string","short")            && Returns 0
  1556. *
  1557. *--------------------------------------------------------------------
  1558.  
  1559.    PRIVATE lc_len
  1560.  
  1561.    m->lc_len = LEN( m->pc_target )
  1562.  
  1563.    DO WHILE m->lc_len > 0
  1564.      IF m->pc_source $ SUBSTR(m->pc_target, m->lc_len)
  1565.        EXIT
  1566.      ELSE
  1567.        m->lc_len = (m->lc_len - 1)
  1568.      ENDIF
  1569.    ENDDO
  1570.  
  1571.    RETURN m->lc_len
  1572.  
  1573. *-- EOF: _Rat( pc_source, pc_target )
  1574.  
  1575. {    return;
  1576. enddef
  1577.  
  1578. //--------------------------------------------------------------
  1579. define make_help()
  1580. // Make the dBASE code for help
  1581. }
  1582. PROCEDURE Help
  1583. PARAMETER lc_var
  1584. *{replicate("-",69)}
  1585. * DESCRIPTION
  1586. *   Activates the HELP window
  1587. *{replicate("-",69)}
  1588. { lmarg(offset)}
  1589. PRIVATE ALL LIKE ??_*
  1590. ON KEY LABEL F1{tabto(41)}&& Dsiable the F1 key during help
  1591. IF .NOT. FILE("{fileroot(hlp_name)}.dbf")
  1592.   *-- Help file has been deleted or can't be found
  1593.   DO _Err_Box WITH "{help_err1}" + "{fileroot(hlp_name)}.dbf"
  1594.   RETURN
  1595. ENDIF
  1596. ll_cat = SET( "CATALOG" ) = "ON"
  1597. SET CATALOG OFF
  1598.  
  1599. SET CURSOR OFF
  1600.  
  1601. *-- Select workarea and open Help dbf
  1602. lc_area = ALIAS()
  1603.  
  1604. *-- Open the HELP dbf file for the form
  1605. SELECT SELECT()
  1606. USE {fileroot(hlp_name)} ORDER fld_name NOUPDATE NOLOG
  1607.  
  1608. ll_exact = SET("EXACT") = "ON"
  1609. SET EXACT ON
  1610. SEEK lc_var{tabto(41)}&& Search for the field name in help
  1611. IF .NOT. ll_exact
  1612.   SET EXACT OFF
  1613. ENDIF
  1614. IF FOUND()
  1615.   *-- Define the coord for the help window
  1616.   ln_t = 5
  1617.   ln_l = 6
  1618.   ln_b = 15
  1619.   ln_r = 74
  1620.   ON KEY LABEL F3 DO Toggle
  1621.   DEFINE WINDOW z_help FROM ln_t+1, ln_l+2 TO ln_b-1, ln_r-2 NONE
  1622.   ON ERROR lc_error=error()
  1623.   SAVE SCREEN TO zz_help
  1624.  
  1625.   *-- Make Help Box
  1626.   DO shadowg WITH ln_t, ln_l, ln_b, ln_r
  1627.   @ ln_t+1, ln_l+1 CLEAR TO ln_b-1, ln_r-1
  1628.   @ ln_t, ln_l TO ln_b, ln_r DOUBLE
  1629.  
  1630.   ln_memline = SET("MEMO")
  1631.   SET MEMOWIDTH TO 65
  1632.   IF MEMLINES(fld_help) > 9
  1633.     @ ln_t+1,ln_r SAY CHR(24)
  1634.     @ ln_b-1,ln_r SAY CHR(25)
  1635.   ENDIF
  1636.   lc_string = CHR(185)+ [ Help for ] + TRIM(fld_headng) +[ ] + CHR(204)
  1637.   lc_message = IIF(MEMLINES(fld_help) > 9, ;
  1638.                   "{help_msg1 + help_msg2}", ;
  1639.                   "{help_msg2}" ;
  1640.                   )
  1641.  
  1642.   @ ln_t,CENTER(lc_string,80) SAY lc_string
  1643.   @ 0,0 GET fld_help OPEN WINDOW z_help MESSAGE lc_message
  1644.   READ
  1645.   SET MEMOWIDTH TO ln_memline
  1646.   ON ERROR
  1647.   ON KEY LABEL F3
  1648.   RELEASE WINDOW z_help
  1649.   RESTORE SCREEN FROM zz_help
  1650.   RELEASE SCREEN zz_help
  1651. ELSE
  1652.   DO _Err_Box WITH [{help_err2} ] + lc_var
  1653. ENDIF
  1654. SET MESSAGE TO
  1655. IF ll_cat
  1656.   SET CATALOG ON
  1657. ENDIF
  1658. SET CURSOR ON
  1659. USE{tabto(41)}&& Close help file
  1660. SELECT (lc_area){tabto(41)}&& Back to edit work area
  1661. ON KEY LABEL F1 DO Help WITH VARREAD()
  1662. {    lmarg(0)}
  1663. RETURN
  1664. *-- EOP: HELP
  1665.  
  1666.  
  1667. PROCEDURE Toggle
  1668. *{replicate("-",69)}
  1669. * DESCRIPTION
  1670. *   Toggles the Help message back to the original screen
  1671. *{replicate("-",69)}
  1672. {    lmarg(offset)}
  1673. PRIVATE ll_cons
  1674. SAVE SCREEN to Toggle
  1675. RESTORE SCREEN FROM zz_help
  1676. SET MESSAGE TO "Press any key..."
  1677. ll_cons = SET( "CONSOLE" ) = "ON"
  1678. SET CONSOLE OFF
  1679. WAIT
  1680. IF ll_cons
  1681.   SET CONSOLE ON
  1682. ENDIF
  1683. RESTORE SCREEN FROM Toggle
  1684. RELEASE SCREEN Toggle
  1685. SET MESSAGE TO "Scroll thru Help: Ctrl-Home   Exit Viewing Help: Ctrl-End   See Org. Screen: F3"
  1686. {    lmarg(0)}
  1687. RETURN
  1688. *-- EOP: Toggle
  1689.  
  1690.  
  1691. FUNCTION Center
  1692. PARAMETER lc_string, ln_width
  1693. *{replicate("-",69)}
  1694. * NAME
  1695. *   Center() - Provide column needed to center a string in a width
  1696. *
  1697. * DESCRIPTION 
  1698. *   The CENTER() function will return the starting column 
  1699. *   coordinate to center the <lc_string> string within a width of 
  1700. *   screen <ln_width>.  The width of the screen would normally be 
  1701. *   80 colunms, but could just as well be the width of a window.  
  1702. *   If there is an error condition, the returned result will equal 0.
  1703. *   If a numeric value is passed for the <expC> value, it will be 
  1704. *   converted to a string.
  1705. * 
  1706. * EXAMPLES
  1707. * 
  1708. *   @ 15,center(string,80) say string    
  1709. * 
  1710. *   Will center the <string> withing 80 columns
  1711. * 
  1712. *-----------------------------------------------------------------------------
  1713.   PRIVATE lc_result, lc_type
  1714.  
  1715.   IF .NOT. TYPE("ln_width") $ "FN"{tabto(41)}&& Force value to 0 for bad type
  1716.     lc_result = 0
  1717.   ELSE
  1718.  
  1719.     lc_type = TYPE("lc_string")
  1720.     DO CASE
  1721.       CASE lc_type = "C"
  1722.         lc_width = (ln_width/2)-(LEN(lc_string)/2)
  1723.       CASE lc_type $ "NF"
  1724.         lc_width = (ln_width/2)-(LEN(ALLTRIM(STR(lc_string)))/2)
  1725.       CASE lc_type = "L"
  1726.         lc_width = (ln_width/2)-(1.5){tabto(41)}&& .T. or .F. have fixed len of 3
  1727.       OTHERWISE                          
  1728.         lc_width = 0
  1729.     ENDCASE
  1730.   ENDIF
  1731.   
  1732.   IF lc_width < 0{tabto(41)}&& Force negative values to 0
  1733.     lc_width = 0
  1734.   ENDIF
  1735.  
  1736. RETURN ( lc_width )
  1737. *-- EOF: Center( lc_string, ln_width )
  1738.  
  1739. {return;
  1740. enddef
  1741.  
  1742. define output_set_proc_code()
  1743. }
  1744. *-- Set procedure to the lookup programs
  1745. ll_echo = SET( "ECHO" ) = "ON"
  1746. SET ECHO OFF
  1747.  
  1748. lc_proc = SET("procedure"){tabto(41)}&& Store procedure file name
  1749. IF FILE("{cap_first(udf_filename)}.prg") .OR. FILE("{cap_first(udf_filename)}.dbo")
  1750.   SET PROCEDURE TO {cap_first(udf_filename)}
  1751. ELSE
  1752.   lc_fullpath = SET("FULLPATH")
  1753.   SET FULLPATH ON
  1754.   lc_setfmt = SET("FORMAT")
  1755.  
  1756.   *-- Pull out the file path from the format file for a prefix
  1757.     lc_slash = IIF( LEFT( OS(), 3 ) = "DOS", "\", "/" )
  1758.  
  1759.     *-- Look for last slash in the string
  1760.     m->lc_len = LEN( lc_setfmt )
  1761.     DO WHILE m->lc_len > 0
  1762.       IF m->lc_slash $ SUBSTR(m->lc_setfmt, m->lc_len)
  1763.         EXIT
  1764.       ELSE
  1765.         m->lc_len = m->lc_len - 1
  1766.       ENDIF
  1767.     ENDDO
  1768.  
  1769.   lc_fullnam = LEFT( lc_setfmt, m->lc_len ) + "{cap_first(udf_filename)}"
  1770.   IF FILE( lc_fullnam + ".prg" ) .OR. FILE( lc_fullnam + ".dbo" )
  1771.     SET PROCEDURE TO ( lc_fullnam )
  1772.   ELSE
  1773.  
  1774.     *-- Display the error message in a windowed box
  1775.     PRIVATE lc_anykey, lc_msg, lc_msglen, lc_win, ln_press, ln_width, ll_trap,;
  1776.             ll_escape
  1777.  
  1778.     lc_anykey = [Press any key to continue...]
  1779.     ln_press  = LEN( lc_anykey )
  1780.     lc_msg = "{proc_err} {cap_first(udf_filename)} {file_err}"
  1781.     ln_msglen = LEN( lc_msg )
  1782.     ln_width = 0
  1783.     ll_escape = SET("ESCAPE") = "ON"
  1784.     SET ESCAPE OFF
  1785.  
  1786.     *-- Determine the width needed for the window:
  1787.     IF ln_msglen <= ln_press
  1788.       ln_width = ln_press
  1789.     ELSE
  1790.       *-- Make sure the message fits in the window:
  1791.       IF ln_msglen > 76
  1792.         lc_msg = LEFT( lc_msg, 76 )
  1793.         ln_msglen = 76
  1794.       ENDIF
  1795.       ln_width = ln_msglen
  1796.     ENDIF
  1797.     DEFINE WINDOW _err_box FROM 9, ((76 - ln_width) + .5) / 2 ;
  1798.                   TO 15, (ln_width + 83) / 2 DOUBLE
  1799.     ln_width = ( ln_width + 2 )
  1800.  
  1801.     *-- Display the message and prompt to the window and wait for a key press
  1802.     ACTIVATE WINDOW _err_box
  1803.     ? lc_msg AT ( ln_width - ln_msglen ) / 2 
  1804.     ?
  1805.     ? lc_anykey AT ( ln_width - ln_press ) / 2 
  1806.     SET CONSOLE OFF
  1807.     WAIT
  1808.     SET CONSOLE ON
  1809.  
  1810.     *-- Clean up the window display and reactivate the previous window
  1811.     RELEASE WINDOW _err_box
  1812.  
  1813.     IF ll_escape
  1814.       SET ESCAPE ON
  1815.     ELSE
  1816.       SET ESCAPE OFF
  1817.     ENDIF
  1818.  
  1819.   ENDIF
  1820.  
  1821.   IF lc_fullpath = "OFF"
  1822.     SET FULLPATH OFF
  1823.   ENDIF
  1824.  
  1825. ENDIF{tabto(41)}&&   UDF's won't run
  1826.  
  1827. {
  1828. return;
  1829. enddef
  1830. // EOP FORM.COD
  1831. }
  1832.