home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / RL.LIF / RLFRONT.PRG < prev   
Encoding:
Text File  |  1991-04-14  |  37.7 KB  |  1,844 lines
  1. /***
  2. *  
  3. *   Rlfront.prg
  4. *   Front end for REPORT and LABEL FORM design program
  5. *  
  6. *   Copyright (c) 1987, 1990 Nantucket Corp.  All rights reserved.
  7. *  
  8. *   Jon P. Rognerud (user interface)
  9. *   Kevin Shepherd  (file interface)
  10. *     
  11. *   Note: Compile with /m
  12. */
  13.  
  14. // File-wide definitions
  15. #include "inkey.ch"
  16. #include "setcurs.ch"
  17.  
  18. // Event types
  19. #define E_CANCEL        1        // Cancel, continue
  20. #define E_NO            2        // Exit, no save
  21. #define E_OK            3        // Exit, save
  22.  
  23.  
  24. LOCAL cStartScr
  25.  
  26. PUBLIC file_error, exit_status, my_update, no_save_flag, form_state
  27.  
  28. file_error = 0                 // File ok
  29.  
  30. SET SCOREBOARD OFF              // Row 0 is being used
  31. SET WRAP ON
  32. SAVE SCREEN TO cStartScr       // Save beginning screen
  33.  
  34. RlMain()                            // Edit reports and label definitions
  35.  
  36. RESTORE SCREEN FROM cStartScr
  37. RETURN
  38.  
  39.  
  40. /***
  41. *     SayMsg( cMessage ) --> NIL
  42. *  Display a message to the message line
  43. *
  44. */
  45. FUNCTION SayMsg( cMsg )
  46.     LOCAL cLastColor := SETCOLOR("n/gr")
  47.     @ 2,0 SAY cMsg 
  48.     SETCOLOR( cLastColor )    
  49.     RETURN NIL
  50.  
  51. /***
  52. *     SignOn() --> NIL
  53. *     Display the sign-on message and wait for a key
  54. *
  55. */
  56. FUNCTION SignOn( aMenu )
  57.     LOCAL cLastColor, lLastCursor
  58.  
  59.     cLastColor = SETCOLOR("N/BG")
  60.     @ 0, 0 SAY aMenu[ 1 ] 
  61.     SETCOLOR( cLastColor )
  62.     lLastCursor := SETCURSOR( SC_NONE )
  63.  
  64.     @ 0, 10 SAY aMenu[ 2 ]
  65.     @ 0, 19 SAY aMenu[ 3 ]
  66.   @ 1, 0  TO 1, MAXCOL()
  67.     SayMsg( "RL - Copyright (c) 1986, 1987, 1990 Nantucket Corp., " +;
  68.             "All Rights Reserved" )
  69.  
  70.     CLEAR TYPEAHEAD
  71.     nKey = INKEY(0)
  72.     @ 2, 0
  73.     KEYBOARD CHR( nKey )
  74.  
  75.     SETPOS( 0, 0 )
  76.     SETCURSOR( lLastCursor )
  77.  
  78.     RETURN NIL
  79.  
  80. /***
  81. *  RlMain() -->
  82. *
  83. *  main procedure
  84. *
  85. *     event types are:
  86. *          1 = cancel, (continue)
  87. *          2 = No,     (exit-no save)
  88. *          3 = Ok,     (exit-w/ save)
  89. */
  90.  
  91. PROCEDURE RlMain
  92.     LOCAL aMainMenu
  93.  
  94.     PRIVATE rl_opt1, rl_opt2, rl_quit
  95.     PRIVATE rl_choice, execute, filename, open_name, file_box, event_type
  96.  
  97.     // item functions must be listed in ascending order...that
  98.     // is, higher numbered items must be located at a higher
  99.     // row number, a higher column number, or both.
  100.     DECLARE file_box[5]
  101.  
  102.     // item functions used in this program
  103.     file_box[1] = "enter_title(sysparam)"
  104.     file_box[2] = "rl_getfil(sysparam)"
  105.     file_box[3] = "ok_button(sysparam)"
  106.     file_box[4] = "cancel_button(sysparam)"
  107.     file_box[5] = "filelist(sysparam)"
  108.  
  109.     okee_dokee = "do_it()"
  110.     execute = .T.
  111.     aMainMenu := { " Report ", " Label ", " Quit " }
  112.  
  113.     SET COLOR TO BG+/B,N/BG,,,N/W
  114.   CLEAR
  115.   SignOn( aMainMenu )
  116.  
  117.     DO WHILE execute
  118.         CLEAR
  119.  
  120.         event_type   = E_CANCEL            // loop
  121.         filename     = SPACE(64)
  122.  
  123.         // Set flags
  124.         my_update    = .F.
  125.         no_save_flag = .F.
  126.  
  127.         // Display main menu
  128.         @ 0, 0  PROMPT aMainMenu[ 1 ]
  129.         @ 0, 10 PROMPT aMainMenu[ 2 ]
  130.         @ 0, 19 PROMPT aMainMenu[ 3 ]
  131.       @ 1, 0  TO 1, MAXCOL()
  132.  
  133.         MENU TO rl_choice
  134.         SET CURSOR OFF
  135.  
  136.         DO CASE
  137.         CASE rl_choice == 3 .OR. rl_choice == 0
  138.  
  139.             // Exit
  140.             execute = .F.
  141.  
  142.         CASE rl_choice == 1
  143.  
  144.             // Select REPORT FORM
  145.             DECLARE files[adir("*.FRM") + 1]
  146.             afill(files,"")
  147.             adir("*.FRM", files)
  148.       altd()
  149.  
  150.             IF multibox(7, 17, 7, 5, file_box) = 0        // <esc> or cancel?
  151.                 LOOP
  152.             ENDIF
  153.  
  154.         // add an extension if none was found (.frm)
  155.             open_name = EXT_ADD(filename, "R")  
  156.  
  157.         CASE rl_choice == 2
  158.  
  159.             // Select LABEL FORM
  160.             DECLARE files[adir("*.LBL") + 1]
  161.             afill(files,"")
  162.             adir("*.LBL", files)
  163.  
  164.             IF multibox(7, 17, 7, 5, file_box) = 0        // <esc> or cancel?
  165.                 LOOP
  166.             ENDIF
  167.  
  168.         // Add an extension if none was found (.lbl)
  169.             open_name = EXT_ADD(filename, "L")  
  170.  
  171.         ENDCASE
  172.  
  173.       IF EMPTY( filename )
  174.          execute = .F.
  175.       ENDIF
  176.  
  177.     IF execute
  178.  
  179.       * report choice was selected from menu bar
  180.         IF rl_choice == 1
  181.  
  182.             SET COLOR TO BG*+/B
  183.             @ 2,0 SAY "Loading..."
  184.             SET COLOR TO BG+/B,N/BG,,,N/W
  185.  
  186.             IF !FRM_LOAD(open_name, "FRM_FILE.DBF", "FRM_FILE.MEM")
  187.                 FRM_ERROR(open_name, file_error)
  188.                 EXIT
  189.             ENDIF
  190.  
  191.             * proceed to editing the report
  192.             DO WHILE (event_type == 1)
  193.  
  194.             * initital state of report screen (fields screen)
  195.                form_state = 3
  196.  
  197.             * the edit routine
  198.                IF FRM_EDIT(open_name, "FRM_FILE.DBF", "FRM_FILE.MEM")
  199.  
  200.                 * get the event_type from selection box upon exit
  201.                    event_type = SYSTEM_EXIT()
  202.  
  203.                     IF event_type == 2        // 'No' button was selected
  204.                         event_type = 0
  205.                     ENDIF
  206.  
  207.                     IF event_type == 3        // 'Ok' button was selected
  208.                            IF !FRM_SAVE(open_name, "FRM_FILE.DBF", "FRM_FILE.MEM")
  209.                                FRM_ERROR(open_name, file_error)
  210.  
  211.                          * exit while loop, some error was found
  212.                                event_type = 0
  213.                         ENDIF
  214.                     ENDIF
  215.  
  216.                 ELSE
  217.  
  218.                * no update (my_update) when editing, go home
  219.                     event_type = 0    
  220.  
  221.                 ENDIF
  222.  
  223.             ENDDO
  224.  
  225.             * delete work files, always
  226.             DELETE FILE frm_file.dbf
  227.             DELETE FILE frm_file.mem
  228.  
  229.         ENDIF    // rl_choice = 1
  230.  
  231.       * label choice was selected from menu bar
  232.         IF rl_choice == 2    
  233.  
  234.             SET COLOR TO BG*+/B
  235.             @ 2,10 SAY "Loading..."
  236.             SET COLOR TO BG+/B
  237.             IF !LBL_LOAD(open_name, "LBL_FILE.DBF", "LBL_FILE.MEM")
  238.                 LBL_ERROR(open_name, file_error)
  239.                 EXIT
  240.             ENDIF
  241.  
  242.             *  edit the label file
  243.             DO WHILE (event_type == 1)
  244.  
  245.                 IF LBL_EDIT(open_name, "LBL_FILE.DBF", "LBL_FILE.MEM")
  246.  
  247.                     event_type = SYSTEM_EXIT()
  248.  
  249.                     IF event_type == 2        // 'No' button
  250.                         event_type = 0
  251.                     ENDIF
  252.  
  253.                     IF event_type == 3
  254.                         IF !LBL_SAVE(open_name, "LBL_FILE.DBF", "LBL_FILE.MEM")
  255.                             LBL_ERROR(open_name, file_error)
  256.                             event_type = 0
  257.                         ENDIF
  258.                     ENDIF
  259.  
  260.                 ELSE
  261.  
  262.                * no update (my_update) when editing, go home
  263.                     event_type = 0
  264.  
  265.                 ENDIF
  266.  
  267.             ENDDO
  268.  
  269.             * delete work files
  270.             DELETE FILE lbl_file.dbf
  271.             DELETE FILE lbl_file.mem
  272.  
  273.         ENDIF
  274.  
  275.     ENDIF
  276.  
  277. ENDDO
  278.  
  279. SET CURSOR ON
  280. // end of RlMain (procedure)
  281.  
  282. ***
  283. * lbl_clear (function)
  284. *
  285. * clear gets for label system
  286. ***
  287. PROCEDURE lbl_clear
  288. PARAMETERS dummy1, dummy2, dummy3
  289. CLEAR GETS
  290. RETURN
  291.  
  292. ***
  293. * lbl_edit (function)
  294. *
  295. * edit a label file
  296. ***
  297. FUNCTION LBL_EDIT
  298. PARAMETERS label_file, label_dbf, label_mem
  299.  
  300. PRIVATE field_list, paint_only
  301.  
  302. exit_status = .F.
  303.  
  304. // get default .MEM file info
  305. RESTORE FROM &label_mem ADDITIVE
  306.  
  307. // .DBF file info
  308. SELECT 0
  309. USE &label_dbf ALIAS label_dbf
  310.  
  311. DECLARE field_list[FCOUNT()]
  312.  
  313. FOR n = 1 TO FCOUNT()
  314.     field_list[n] = FIELDNAME(n)
  315. NEXT
  316.  
  317. // draw the screen once
  318. LBL_SCR(label_file)
  319.  
  320. // cursor back on (multibox sets it off)
  321. SET CURSOR ON
  322.  
  323. paint_only = .T.
  324. DO WHILE !exit_status
  325.  
  326.     * set 'break-out' key, toggle switch
  327.     SET KEY -1 TO lbl_clear    // (F2)
  328.  
  329.     * set label format key
  330.     SET KEY -2 TO lab_setup
  331.  
  332.     * set F10 key to the exit procedure
  333.     SET KEY -9 TO set_exit_flag
  334.  
  335.     @ 05,16 GET lbl_width  PICTURE "999"
  336.     @ 06,16 GET lbl_height PICTURE "999" VALID LINE_CHK(lbl_height)
  337.     @ 07,16 GET lbl_across PICTURE "999"
  338.  
  339.     @ 05,52 GET lbl_margin PICTURE "999"
  340.     @ 06,52 GET lbl_lines  PICTURE "999"
  341.     @ 07,52 GET lbl_spaces PICTURE "999"
  342.  
  343.     @ 09,16 GET lbl_remark
  344.  
  345.     IF !paint_only
  346.         READ
  347.     ENDIF
  348.  
  349.     my_update = my_update .OR. UPDATED()
  350.  
  351.     IF exit_status
  352.          EXIT
  353.   ENDIF
  354.  
  355.     * send the escape key to exit from dbedit the first time    
  356.     IF paint_only
  357.         CLEAR GETS
  358.         KEYBOARD CHR(27)
  359.         paint_only = .F.
  360. //    ELSE
  361. //     KEYBOARD CHR(31)
  362.     ENDIF
  363.  
  364.     * view/edit field expressions
  365.     SET KEY -9 TO
  366.   SET KEY 1  TO Home_key
  367.   SET KEY 6  TO End_key
  368.   SET KEY -1 TO
  369.  
  370.     SET CURSOR OFF
  371.     @ 12,0 SAY "Line " + LTRIM(STR(RECNO())) + " ═"
  372.     DBEDIT(11, 7, 23, 79, field_list, "LBL_ED")
  373.     SET CURSOR ON
  374.  
  375.     SET KEY -9 TO set_exit_flag
  376.   SET KEY 1  TO 
  377.   SET KEY 6  TO 
  378.  
  379. ENDDO
  380.  
  381. CLOSE DATABASES
  382.  
  383. IF my_update .AND. !no_save_flag
  384.     * save off to .mem file, if it was updated and 'No' was not selected
  385.     SAVE ALL LIKE lbl_*.* TO &label_mem
  386. ENDIF
  387.  
  388. // disable SET KEY's
  389. SET KEY -1 TO
  390. SET KEY -2 TO
  391. SET KEY -9 TO
  392.  
  393. RETURN (my_update)
  394. // end of lbl_edit (function)
  395.  
  396.  
  397. PROCEDURE Home_key
  398. KEYBOARD CHR(31)
  399. RETURN
  400.  
  401. PROCEDURE End_key
  402. KEYBOARD CHR(30)
  403. RETURN     
  404.  
  405. ***
  406. *    lab_setup (procedure)
  407. *
  408. *    handle the various formats that dBASE supports
  409. ***
  410. PROCEDURE lab_setup
  411. PARAMETERS procName, dummy2, dummy3
  412.  
  413. PRIVATE double, more, type, type1, type2, type3, type4, type5
  414.  
  415. double = "╔═╗║╝═╚║"
  416.  
  417. SAVE SCREEN
  418.  
  419. @ 08,18,20,57 BOX ""    // space around window
  420.  
  421. // make window
  422. @ 10,20,18,55 BOX double
  423.  
  424. // disable options
  425. SET KEY -1 TO
  426. SET KEY -2 TO
  427. SET KEY 1  TO 
  428. SET KEY 6  TO 
  429.  
  430. // no F10 here, ESC returns
  431. SET KEY -9 TO
  432.  
  433. // various label types
  434. type1 = "     3 1/2 x 15/16 by 1       "
  435. type2 = "     3 1/2 x 15/16 by 2       "
  436. type3 = "     3 1/2 x 15/16 by 3       "
  437. type4 = "       4 x 17/16 by 1         "
  438. type5 = "3 2/10 x 11/12 by 3 (Cheshire)"
  439.  
  440. more = .T.
  441. DO WHILE more
  442.  
  443.     * selections
  444.     @ 12,23 PROMPT type1
  445.     @ 13,23 PROMPT type2
  446.     @ 14,23 PROMPT type3
  447.     @ 15,23 PROMPT type4
  448.     @ 16,23 PROMPT type5
  449.  
  450.     MENU TO lab_choice
  451.  
  452.     * set up the strings, based on choice
  453.     DO CASE
  454.         CASE lab_choice = 0
  455.             more = .F.
  456.         CASE lab_choice = 1
  457.             type = LTRIM(TRIM(type1)) + SPACE(60-18)
  458.             more = stuff_label(35,5,0,1,0,1,type)
  459.             UpdateHeight(5)
  460.         CASE lab_choice = 2
  461.             type = LTRIM(TRIM(type2)) + SPACE(60-18)
  462.             more = stuff_label(35,5,0,1,2,2,type)
  463.             UpdateHeight(5)
  464.         CASE lab_choice = 3
  465.             type = LTRIM(TRIM(type3)) + SPACE(60-18)
  466.             more = stuff_label(35,5,0,1,2,3,type)
  467.             UpdateHeight(5)
  468.         CASE lab_choice = 4
  469.             type = LTRIM(TRIM(type4)) + SPACE(60-14)
  470.             more = stuff_label(40,8,0,1,0,1,type)
  471.             UpdateHeight(8)
  472.         CASE lab_choice = 5
  473.             type = type5 + SPACE(60-30)
  474.             more = stuff_label(32,5,0,1,2,3,type)
  475.             UpdateHeight(5)
  476.     ENDCASE
  477.  
  478. ENDDO
  479.  
  480. SET KEY 1  TO Home_key
  481. SET KEY 6  TO End_key
  482.  
  483. CLEAR GETS
  484.  
  485. // break out of dbedit()
  486. KEYBOARD CHR(27)
  487.  
  488. RESTORE SCREEN
  489. RETURN
  490. // end of lab_setup (procedure)
  491.  
  492. ***
  493. *    stuff_label (function)
  494. *
  495. *    stuff label variables with values from lbl_setup, return .F.
  496. ***
  497. FUNCTION stuff_label
  498. PARAMETERS one,two,three,four,five,six,seven
  499.  
  500. lbl_width  = one
  501. lbl_height = two
  502. lbl_margin = three
  503. lbl_lines  = four
  504. lbl_spaces = five
  505. lbl_across = six
  506. lbl_remark = seven
  507.  
  508. // generates an update
  509. my_update = .T.
  510.  
  511. RETURN (.F.)
  512. // end of stuff_label (function)
  513.  
  514. ***
  515. *    lbl_ed (function)
  516. *
  517. *    user defined function to be called from DBEDIT, used in LBL_EDIT
  518. ***
  519. FUNCTION LBL_ED
  520. PARAMETERS mode, i
  521.  
  522. PRIVATE cur_field
  523.  
  524. // get the name of the current field into a regular variable
  525. cur_field = field_list[i]
  526.  
  527. DO CASE
  528. CASE mode = 0
  529.     * idle mode...
  530.     @ 12,0 SAY "Line " + LTRIM(STR(RECNO())) + " ═"
  531.     RETURN(1)
  532.  
  533. CASE mode = 1
  534.     KEYBOARD CHR(30)
  535.     RETURN 1
  536.  
  537. CASE mode = 2
  538.   KEYBOARD CHR(31)
  539.   RETURN 1
  540.  
  541. CASE mode < 4
  542.   * case action can be implemented for each mode
  543.   RETURN (1)
  544.  
  545. CASE LASTKEY() = -1                                      // F2
  546.     SET CURSOR ON
  547.     RETURN (0)
  548.  
  549. CASE LASTKEY() = 7
  550.   * Del..delete current line.
  551.   rec_num = RECNO()
  552.   DELETE
  553.   PACK
  554.   APPEND BLANK
  555.  
  556.   GO REC_NUM
  557.   my_update = .t.
  558.  
  559.   RETURN 2
  560.  
  561. CASE LASTKEY() = 27
  562.     RETURN (0)
  563.  
  564. CASE LASTKEY() = 13 .OR. LASTKEY() > 32 .AND. LASTKEY() < 128
  565.     * force key into GET field
  566.     IF LASTKEY() != 13
  567.         KEYBOARD CHR(LASTKEY())
  568.   ENDIF
  569.  
  570.     * enter key..edit the current field
  571.     * ..current row and col are correct
  572.     @ ROW(), COL() GET &cur_field
  573.  
  574.     * set curson on and edit the expressions
  575.     SET CURSOR ON
  576.     SET KEY -9 TO set_exit_flag
  577.     SET KEY 1 TO
  578.     SET KEY 6 TO
  579.  
  580.     READEXIT(.T.)
  581.     READ
  582.     READEXIT(.F.)
  583.  
  584.     SET KEY -9 TO
  585.     SET KEY 1 TO home_key
  586.     SET KEY 6 TO end_key
  587.  
  588.     SET CURSOR OFF
  589.  
  590.     * set the update flag
  591.     my_update = my_update .OR. UPDATED()
  592.     IF LASTKEY() = 13
  593.         KEYBOARD CHR(24)
  594.     ENDIF
  595.  
  596.     * don't quit
  597.      RETURN(1)
  598.  
  599. CASE LASTKEY() = -9
  600.     exit_status = .T.
  601.     RETURN 0
  602.  
  603. OTHERWISE
  604.     * don't quit
  605.     RETURN 1
  606.  
  607. ENDCASE
  608. // end of lbl_ed (function)
  609.  
  610.  
  611. ***
  612. * lbl_scr (function)
  613. *
  614. * paint the label screen using SAY's
  615. ***
  616. FUNCTION LBL_SCR
  617. PARAMETERS label_file
  618.  
  619. CLEAR
  620.  
  621. @ 0,00 SAY "F1"
  622. @ 0,09 SAY "F2"
  623. @ 0,20 SAY "F3"
  624. @ 0,70 SAY "F10"
  625.  
  626. @ 1,00 SAY "Help"
  627. @ 1,09 SAY "Toggle"
  628. @ 1,20 SAY "Formats"
  629. @ 1,70 SAY "Exit"
  630.  
  631. @ 2,0 SAY REPLICATE(CHR(196),80)
  632.  
  633. // display the filename all the way to the right
  634. @ 03,80-LEN("File " + label_file) SAY "File " + label_file
  635.  
  636. // display headers
  637. @ 04,01 SAY "Dimensions"
  638. @ 04,30 SAY "Formatting"
  639.  
  640. @ 05,06 SAY "Width   "
  641. @ 06,06 SAY "Height  "
  642. @ 07,06 SAY "Across  "
  643. @ 05,36 SAY "Margin  "
  644. @ 06,36 SAY "Lines   "
  645. @ 07,36 SAY "Spaces  "
  646. @ 09,06 SAY "Remarks "
  647.  
  648. RETURN ("")
  649. // end of lbl_scr (function)
  650.  
  651. ***
  652. * 
  653. * line_chk (function)
  654. *
  655. * Check the line_height variable.  Report error if not in range. Modify 
  656. * database to accomodate new values, if any. Return Boolean valid_flag.
  657. ***
  658. FUNCTION LINE_CHK
  659. PARAMETERS height, file
  660.  
  661. PRIVATE lines, range_error, valid_flag, i
  662.  
  663. range_error = "(Valid range is between 1 and 16.)"
  664. valid_flag  = .T.
  665.  
  666. SET CURSOR OFF
  667.  
  668. IF height > 16 .OR. height <= 0
  669.         @ 24, CENTER(range_error,80) SAY range_error
  670.         valid_flag = .F.
  671.  
  672. ELSEIF height != LASTREC()
  673.  
  674.         UpdateHeight(height)
  675.       @ 24,0    // ok to clear line
  676. END
  677.  
  678. SET CURSOR ON
  679.  
  680. RETURN (valid_flag)
  681. // end of line_chk (function)
  682.  
  683. ***
  684. *
  685. *     UpdateHeight(height, lines)
  686. *         Delete added lines or expand to fill if lines are less than height.
  687. *        Uses inherited privates vars.
  688. *
  689. *        8/13/89 CEW
  690. *
  691. PROCEDURE UpdateHeight
  692.  
  693.         PARAMETERS height
  694.  
  695.       * delete lineitems
  696.       DELETE ALL FOR RECNO() > height
  697.       PACK
  698.  
  699.         * add lineitems
  700.         lines = RECCOUNT()
  701.       IF height > lines
  702.           DO WHILE lines < height
  703.               APPEND BLANK
  704.               SKIP
  705.               lines = lines + 1
  706.           ENDDO
  707.           GO TOP    // reset
  708.       ENDIF
  709.  
  710. RETURN
  711.  
  712. ***
  713. *  set_exit_flag (procedure)
  714. *
  715. *  sets the global exit_status flag to .T. upon exit (F10).
  716. ***
  717. PROCEDURE set_exit_flag
  718. CLEAR GETS
  719. exit_status = .T.
  720. RETURN
  721. // end of set_exit_flag (procedure)
  722.  
  723. ***
  724. * system_exit (function)
  725. *
  726. * save changes to file ...?   Ok     - Save and exit
  727. *                                    No     - Exit
  728. *                                     Cancel - loop (continue)
  729. ****
  730. FUNCTION system_exit
  731. PARAMETERS dummy1, dummy2, dummy3
  732.  
  733. PRIVATE exit_box, continue
  734.  
  735. continue = 3    // save and exit
  736.  
  737. DECLARE exit_box[4]
  738.  
  739. exit_box[1] = "save_title(sysparam)"
  740. exit_box[2] = "ok_button(sysparam)"
  741. exit_box[3] = "no_button(sysparam)"
  742. exit_box[4] = "can_button(sysparam)"
  743.  
  744. SET CURSOR OFF
  745. IF multibox(7, 17, 7, 2, exit_box) = 0        // save changes? (Y,N,C)
  746.  
  747.     continue = 1         // cancel
  748.  
  749.     IF no_save_flag        // set inside multibox routine
  750.         continue = 2
  751.     ENDIF
  752.  
  753. ENDIF
  754. SET CURSOR ON
  755.  
  756. RETURN (continue)
  757. // end of system_exit (function)
  758.  
  759. ****
  760. * frm_edit (function)
  761. *
  762. * this routine calls 6 procedures, using SET KEY <n> TO ...
  763. *
  764. * F-key:                      (procedure name):
  765. * F2 = pageheading screen     (form_layout)
  766. * F3 = group/subgroup screen  (form_groups)
  767. * F4 = default fields screen  (form_fields)
  768. * F5 = delete                 (form_delete)
  769. * F6 = insert                 (form_insert)
  770. * F7 = goto field             (form_goto)
  771. *
  772. ****
  773. FUNCTION FRM_EDIT
  774. PARAMETERS form_file, form_dbf, form_mem
  775.  
  776. PRIVATE phdr_lines, chdr_lines, i, lkey, phdr_flag, insert_flag
  777.  
  778. // get default .MEM file info
  779. RESTORE FROM &form_mem ADDITIVE
  780.  
  781. // .DBF file info
  782. SELECT 0
  783. USE &form_dbf ALIAS form_dbf
  784.  
  785. // set up work arrays
  786. DECLARE phdr_lines[4]
  787. DECLARE chdr_lines[24*4]    // 24 fields, 4 lines each
  788.  
  789. // inititalize pagetitle array
  790. afill(phdr_lines,SPACE(60))
  791.  
  792. // translate semicolons into lines and stuff array
  793. fstart_pos = 1
  794. phdr_lines[1] = XLATE(frm_pagehdr, ";", 60)
  795. phdr_lines[2] = XLATE(frm_pagehdr, ";", 60)
  796. phdr_lines[3] = XLATE(frm_pagehdr, ";", 60)
  797. phdr_lines[4] = XLATE(frm_pagehdr, ";", 60)
  798.  
  799. // initalize contents header array
  800. afill(chdr_lines, SPACE(65), 1, 24*4)
  801.  
  802. // set the array index
  803. ar_index = 1
  804.  
  805. // get the strings from datafile
  806. GO TOP
  807. FOR i = 1 TO RECCOUNT()
  808.  
  809.    * set field start position    
  810.     fstart_pos = 1
  811.  
  812.     * set up fields contents headers
  813.     chdr_lines[ar_index]   = XLATE(form_dbf->header, ";", 65)
  814.     chdr_lines[ar_index+1] = XLATE(form_dbf->header, ";", 65)
  815.     chdr_lines[ar_index+2] = XLATE(form_dbf->header, ";", 65)
  816.     chdr_lines[ar_index+3] = XLATE(form_dbf->header, ";", 65)
  817.  
  818.    * next one
  819.     SKIP
  820.  
  821.     * increment array subscript (in groups of four)
  822.     ar_index = ar_index + 4
  823.  
  824. NEXT
  825.     
  826. // pad the group/subgroup area, if necessary
  827. frm_grpexpr  = frm_grpexpr + SPACE(200 - LEN(frm_grpexpr))
  828. frm_grphdr   = frm_grphdr  + SPACE( 50 - LEN(frm_grphdr ))
  829. frm_subexpr  = frm_subexpr + SPACE(200 - LEN(frm_subexpr))
  830. frm_subhdr   = frm_subhdr  + SPACE( 50 - LEN(frm_subhdr ))
  831.  
  832. // modifying old file
  833. GO TOP
  834. IF frm_colcount != 0    
  835.  
  836.     m_contents = form_dbf->contents
  837.     m_width    = form_dbf->width
  838.     m_decimals = form_dbf->decimals
  839.     m_totals   = form_dbf->totals
  840.  
  841. ***** 03/29/88
  842. * originally:
  843. *    total_fields   = frm_colcount
  844. * fix:
  845.     TOTAL_FIELDS = int(FRM_COLCOUNT)
  846.  
  847.  
  848. ELSE    // modifying new file, frm_colcount == 0
  849.  
  850.     m_contents = SPACE(254)
  851.     m_width    = 10
  852.     m_decimals = 0
  853.     m_totals   = "N"
  854.     total_fields   = 1
  855.  
  856. ENDIF
  857.     
  858. // get the data again if 'Cancel' on filebox
  859. IF my_update
  860.  
  861.     m_contents = form_dbf->contents
  862.     m_width    = form_dbf->width
  863.     m_decimals = form_dbf->decimals
  864.     m_totals   = form_dbf->totals
  865.  
  866. ENDIF
  867.  
  868. insert_flag = .F.    // no inserted fields yet
  869. exit_status = .F.     // exit not set yet
  870.  
  871. // exit on F10
  872. SET KEY -9 TO set_exit_flag
  873.  
  874. key = form_state        // the fields screen
  875.  
  876. // index is always 1 on entry
  877. ar_index = 1
  878.  
  879. // control loop for frm_edit
  880. DO WHILE !exit_status
  881.  
  882.    * set page function keys    
  883.     SET KEY -1 TO clear_gets   // F2
  884.     SET KEY -2 TO clear_gets   // F3         
  885.     SET KEY -3 TO clear_gets   // F4
  886.  
  887.     DO CASE
  888.         CASE M->form_state == 1
  889.             DO form_layout
  890.         CASE M->form_state == 2
  891.             DO form_groups
  892.         CASE M->form_state == 3
  893.             DO form_fields
  894.         CASE M->form_state == 4
  895.             DO form_delete
  896.             form_state = 3
  897.             * DON'T get new key 
  898.             LOOP
  899.         CASE M->form_state == 5
  900.             DO form_insert
  901.             form_state = 3
  902.             * DON'T get new key 
  903.             LOOP
  904.         CASE M->form_state == 6
  905.             DO form_goto
  906.             form_state = 3
  907.             * DON'T get new key 
  908.             LOOP
  909.     ENDCASE
  910.  
  911.     * get the key
  912.     key = LASTKEY()
  913.  
  914.     DO CASE
  915.  
  916.       * if key was F10
  917.         CASE M->key == -9
  918.             DO set_exit_flag
  919.  
  920.         CASE M->key == 27 .OR. M->key == 18 .OR. M->key == 3
  921.             * define your own special 'read-exit' keys here, if needed
  922.         
  923.         ***** 03/29/88
  924.         * fix:
  925.         case m->KEY > 27 .and. m->KEY < 255
  926.  
  927.         OTHERWISE    // the function keys
  928.             form_state = VAL(SUBSTR(LTRIM(STR(M->key)),2))    // get the new state
  929.  
  930.     ENDCASE
  931.  
  932. ENDDO
  933. // check for empty pagetitle
  934. phdr_flag = .F.
  935. FOR i = 1 TO 4
  936.     IF !EMPTY(phdr_lines[i])
  937.         phdr_flag = .T.
  938.     ENDIF
  939. NEXT
  940.  
  941. // get the pageheader if not empty
  942. IF phdr_flag
  943.  
  944. ***** 03/29/88
  945. * originally:
  946. *    frm_pagehdr = TRIM(phdr_lines[1]) + ";" + TRIM(phdr_lines[2])+";" + ;
  947. *              TRIM(phdr_lines[3]) + ";" + phdr_lines[4]
  948. * fix:
  949. frm_pagehdr = IF(!EMPTY(phdr_lines[1]), TRIM(phdr_lines[1]) + ";", SPACE(60)) +;
  950.               IF(!EMPTY(phdr_lines[2]), TRIM(phdr_lines[2]) + ";", SPACE(60)) +;
  951.               IF(!EMPTY(phdr_lines[3]), TRIM(phdr_lines[3]) + ";", SPACE(60)) +;
  952.               IF(!EMPTY(phdr_lines[4]), TRIM(phdr_lines[4]) + ";", SPACE(60))
  953.  
  954. ELSE
  955.     frm_pagehdr = ""
  956. ENDIF
  957.  
  958. // strip of spaces in the group/subgroup areas
  959. frm_grpexpr  = TRIM(frm_grpexpr)
  960. frm_grphdr   = TRIM(frm_grphdr)
  961. frm_subexpr  = TRIM(frm_subexpr)
  962. frm_subhdr   = TRIM(frm_subhdr)
  963.  
  964. // save if updated and 'No' was not selected
  965. IF my_update .AND. !no_save_flag
  966.  
  967.     *  set number of fields
  968.     frm_colcount = MAX(total_fields, frm_colcount)
  969.  
  970.     SAVE ALL LIKE frm_*.* TO &form_mem
  971.     
  972.     * put the semicolon's back on, the simple way
  973.     i = 1
  974.     GO TOP
  975.     DO WHILE .NOT. EOF()
  976.         REPLACE form_dbf->header WITH ;
  977.         TRIM(chdr_lines[i]) + ";" + TRIM(chdr_lines[i+1]) + ";" + ;
  978.         TRIM(chdr_lines[i+2]) + ";" + TRIM(chdr_lines[i+3])
  979.         SKIP
  980.         i = i + 4
  981.     ENDDO
  982.  
  983. ENDIF
  984.  
  985. CLOSE DATABASES
  986.  
  987. // disable SET KEYs ...
  988. FOR i = 1 TO 6
  989.     SET KEY -i TO
  990. NEXT
  991. SET KEY -9 TO 
  992.  
  993. RETURN (my_update)
  994. // end of frm_edit (function)
  995.  
  996. ****
  997. * form_fields (procedure)
  998. *
  999. * called from frm_edit, processes editing requests
  1000. ****
  1001. PROCEDURE form_fields
  1002.  
  1003. PRIVATE stay_msg, no_more_fields, rec_saved
  1004.  
  1005. SET CURSOR ON
  1006.  
  1007. // set up function keys
  1008. SET KEY -4 TO clear_gets    // delete (F5)
  1009. SET KEY -5 TO clear_gets    // insert (F6)
  1010. SET KEY -6 TO clear_gets    // goto # (F7)
  1011.  
  1012. SET KEY -3 TO    // disable this option (F4)
  1013.  
  1014. // draw screen
  1015. FRM_SCR(3)
  1016.  
  1017. // possible error messages
  1018. stay_msg       = "(Must type in inserted field, or delete, before moving)."
  1019. no_more_fields = "(You have reached end of file)."
  1020.  
  1021. break_out = .F.        // flag to break out of WHILE loop
  1022.  
  1023. DO WHILE !exit_status
  1024.  
  1025.    * just in case
  1026.    @ 4,71 SAY IF (!BOF(), "Field " + LTRIM(STR(RECNO())) + " ", "<bof>  ")
  1027.    @ 4,71 SAY IF (!EOF(), "Field " + LTRIM(STR(RECNO())) + " ", "<eof>  ")
  1028.  
  1029.    @ 5,71 SAY "Total " + LTRIM(STR(total_fields)) + " "
  1030.  
  1031.    @ 07,09 GET m_contents PICTURE "@S65"
  1032.  
  1033.    @ 11,09 GET chdr_lines[ar_index]
  1034.    @ 12,09 GET chdr_lines[ar_index+1]
  1035.    @ 13,09 GET chdr_lines[ar_index+2]
  1036.    @ 14,09 GET chdr_lines[ar_index+3]
  1037.  
  1038.    @ 19,10 GET m_width    PICTURE "99"
  1039.    @ 20,10 GET m_decimals PICTURE "99"
  1040.    @ 21,10 GET m_totals   PICTURE "!"
  1041.  
  1042.    READ
  1043.  
  1044.    lkey = LASTKEY()
  1045.  
  1046.    IF break_out        // set in clear_gets procedure
  1047.         EXIT
  1048.    ENDIF
  1049.  
  1050.    * was it updated?
  1051.    my_update = my_update .OR. UPDATED()
  1052.  
  1053.     * F10?
  1054.     IF exit_status
  1055.  
  1056.      IF .NOT. UPDATED() .AND. RECNO() < 24
  1057.              IF total_fields > 0
  1058.                  total_fields = total_fields - 1
  1059.                 ENDIF
  1060.        ELSE
  1061.           IF my_update
  1062.                 REPLACE form_dbf->contents WITH m_contents
  1063.                  REPLACE form_dbf->totals   WITH m_totals
  1064.                    REPLACE form_dbf->width    WITH m_width
  1065.                 REPLACE form_dbf->decimals WITH m_decimals
  1066.            ENDIF
  1067.         ENDIF
  1068.  
  1069.    ENDIF
  1070.  
  1071.    DO CASE
  1072.       CASE lkey == 13 .OR. lkey == 3    // CR or PgDn
  1073.     
  1074.             * put the information in the file when going forward        
  1075.             REPLACE form_dbf->contents WITH m_contents
  1076.             REPLACE form_dbf->totals   WITH m_totals
  1077.             REPLACE form_dbf->width    WITH m_width
  1078.             REPLACE form_dbf->decimals WITH m_decimals
  1079.  
  1080.             IF insert_flag .AND. !my_update
  1081.                 @ 24,CENTER(stay_msg,80) SAY stay_msg
  1082.                 INKEY(5)
  1083.                 @ 24,0
  1084.                 LOOP
  1085.             ELSE
  1086.                 * reset insert flag    
  1087.                 insert_flag = .F.
  1088.             ENDIF
  1089.  
  1090.             * add a new one
  1091.             IF (UPDATED() .AND. RECNO() == LASTREC()) .OR. (RECNO() == LASTREC() .AND. !EMPTY(m_contents))
  1092.  
  1093.                 * save for restore, if illegal APPEND
  1094.                 rec_saved = RECNO()
  1095.  
  1096.                 APPEND BLANK
  1097.  
  1098.                 * no more than 24 fields allowed
  1099.                 IF RECNO() > 24
  1100.  
  1101.                     @ 24,CENTER(no_more_fields,80) SAY no_more_fields
  1102.                     INKEY(2)
  1103.                     DELETE
  1104.                     PACK
  1105.  
  1106.                     @ 24,0
  1107.                     * restore
  1108.                     GO rec_saved
  1109.  
  1110.                     LOOP
  1111.                 ENDIF
  1112.  
  1113.                 * increment array subscript
  1114.                IF ar_index <= 92
  1115.                     ar_index = ar_index + 4
  1116.                 ENDIF
  1117.  
  1118.                 * add the total field count
  1119.                 total_fields = total_fields + 1
  1120.  
  1121.                 * init new field
  1122.               m_contents = SPACE(254)
  1123.                   m_width    = 10
  1124.               m_decimals =  0
  1125.                   m_totals   = "N"
  1126.  
  1127.             ELSE
  1128.  
  1129.               SKIP
  1130.                IF ar_index <= 92
  1131.                   ar_index = ar_index + 4
  1132.                ENDIF
  1133.  
  1134.                 IF EOF()
  1135.  
  1136.                   * no more ...
  1137.                     @ 24,CENTER(no_more_fields,80) SAY no_more_fields
  1138.                     INKEY(3)
  1139.                     @ 24,0
  1140.  
  1141.                    SKIP -1
  1142.  
  1143.                   IF RECNO() < 24
  1144.                       IF ar_index > 1
  1145.                            ar_index = ar_index - 4
  1146.                        ENDIF
  1147.                   ENDIF
  1148.  
  1149.               ENDIF
  1150.     
  1151.                 m_contents = form_dbf->contents
  1152.                  m_width    = form_dbf->width
  1153.               m_decimals = form_dbf->decimals
  1154.                 m_totals   = form_dbf->totals
  1155.     
  1156.             ENDIF
  1157.                                 
  1158.       CASE lkey == 18     // PgUp
  1159.  
  1160.          * put the information in the file when going backward
  1161.            REPLACE form_dbf->contents WITH m_contents
  1162.            REPLACE form_dbf->totals   WITH m_totals
  1163.            REPLACE form_dbf->width    WITH m_width
  1164.            REPLACE form_dbf->decimals WITH m_decimals
  1165.  
  1166.         IF insert_flag .AND. !my_update
  1167.             @ 24,CENTER(stay_msg,80) SAY stay_msg
  1168.             INKEY(3)
  1169.             @ 24,0
  1170.             LOOP
  1171.         ELSE
  1172.             * reset insert flag    
  1173.             insert_flag = .F.
  1174.         ENDIF
  1175.  
  1176.            IF !BOF()
  1177.  
  1178.                SKIP -1
  1179.  
  1180.                IF ar_index > 1
  1181.                    ar_index = ar_index - 4
  1182.                ENDIF
  1183.  
  1184.               m_contents = form_dbf->contents
  1185.               m_width    = form_dbf->width
  1186.                m_decimals = form_dbf->decimals
  1187.               m_totals   = form_dbf->totals
  1188.  
  1189.            ENDIF
  1190.  
  1191.    ENDCASE
  1192.  
  1193. ENDDO
  1194.  
  1195. my_update = my_update .OR. UPDATED()
  1196.  
  1197. RETURN
  1198. // end of form_fields (procedure)
  1199.  
  1200. ***
  1201. * form_insert (procedure)
  1202. *
  1203. * insert a column (field) in the report file
  1204. *
  1205. * insert a field only when:
  1206. *   a) field is not the first one, first time
  1207. *   b) field is not the last one
  1208. *   c) total field count is not larger than maximum, 24
  1209. *
  1210. * Purpose:
  1211. *  shifts fields up by one, inserts a new one
  1212. * 
  1213. * Note: Field that is left blank creates an error in expression area.
  1214. *       Delete 'unused' field to avoid this.
  1215. *
  1216. ***
  1217. PROCEDURE form_insert
  1218. PARAMETERS dummy1, dummy2, dummy3
  1219.  
  1220. PRIVATE saved_record, insert_error, temp
  1221.  
  1222. insert_error = "(Cannot insert field. Insert (F6) invalid here, or maximum is reached)."
  1223.  
  1224. IF RECNO() != 1 .AND. RECNO() != LASTREC() .AND. RECCOUNT() < 24 .AND. !EMPTY(form_dbf->contents)
  1225.  
  1226.     * save position before insert call
  1227.     saved_record = RECNO()
  1228.  
  1229.     * new field, return Boolean to insert_flag for processing in form_fields
  1230.    insert_flag = insert_blank(RECNO())
  1231.     
  1232.     * restore record#
  1233.     GO saved_record
  1234.  
  1235.     * add an item in array, starting at ar_index pos
  1236.     FOR temp = ar_index TO ar_index + 3
  1237.         ains(chdr_lines, ar_index)
  1238.         chdr_lines[ar_index] = SPACE(65)        // no (U) here!
  1239.     NEXT
  1240.  
  1241.    * increment field count variables
  1242.     total_fields = total_fields + 1
  1243.     frm_colcount = frm_colcount + 1
  1244.  
  1245.     * initialize new field
  1246.     m_contents = SPACE(254)
  1247.     REPLACE form_dbf->contents WITH SPACE(254)
  1248.     REPLACE form_dbf->header   WITH SPACE(260)
  1249.     REPLACE form_dbf->width    WITH 10
  1250.     REPLACE form_dbf->totals   WITH "N"
  1251.     REPLACE form_dbf->decimals WITH 0
  1252.  
  1253.     * no update flag for insert
  1254.     my_update = .F.
  1255.  
  1256. ELSE
  1257.  
  1258.     @ 24,CENTER(insert_error,80) SAY insert_error
  1259.     INKEY(4)
  1260. ENDIF
  1261.  
  1262. RETURN
  1263. // end of form_insert (procedure)
  1264.  
  1265. ***
  1266. *  insert_blank (function)
  1267. *
  1268. *  insert a blank record in dbf at position 'pos'
  1269. *
  1270. ***
  1271. FUNCTION insert_blank
  1272. PARAMETERS pos
  1273.  
  1274. PRIVATE inserted
  1275.  
  1276. // yes, we are inserting, set flag
  1277. inserted = .T.
  1278.  
  1279. // set position for insert
  1280. @ 3,0 SAY "Insert at field " + LTRIM(STR(pos)) + " ..."
  1281.  
  1282. // position
  1283. GO pos
  1284.  
  1285. // make temp file, copy the rest of file
  1286. COPY NEXT LASTREC() TO temp
  1287.  
  1288. // mark them, delete
  1289. DELETE ALL FOR RECNO() >= pos
  1290.  
  1291. // add a new one
  1292. APPEND BLANK
  1293.  
  1294. // get the tail list
  1295. APPEND FROM temp
  1296.  
  1297. // remove deleted items
  1298. PACK
  1299.  
  1300. // delete temporary work file, insertion done!
  1301. DELETE FILE temp.DBF
  1302.  
  1303. RETURN (inserted)
  1304. // end of insert_blank (function)
  1305.  
  1306. ***
  1307. * form_delete (procedure)
  1308. *
  1309. * purpose:
  1310. *    delete a column (field) in the report file
  1311. *
  1312. * delete a field when the field is already blank
  1313. * so user has the option to abort process.
  1314. *
  1315. * note: a deletion sets the my_update flag so the file may
  1316. *       be saved to disk.
  1317. * 
  1318. ***
  1319. PROCEDURE form_delete
  1320. PARAMETERS dummy1, dummy2, dummy3
  1321.  
  1322. PRIVATE temp, saved_record, content_error
  1323.  
  1324. content_error = "(Field must be blank to do that.  Use Ctrl-Y to delete)."
  1325.  
  1326. // field contents is empty, OK to delete
  1327. IF EMPTY(m_contents)
  1328.  
  1329.     * remove items in array, starting at ar_index pos
  1330.     FOR temp = ar_index TO ar_index + 3
  1331.         adel(chdr_lines, ar_index)
  1332.         chdr_lines[LEN(chdr_lines)] = SPACE(65)        // no (U) here!
  1333.     NEXT
  1334.  
  1335.     * save this record before delete
  1336.     saved_record = RECNO()
  1337.  
  1338.     DELETE
  1339.     PACK
  1340.  
  1341.     * reset insert flag, in case of 'insert-notyping-delete' process
  1342.     insert_flag = .F.
  1343.  
  1344.     IF !EOF()
  1345.  
  1346.         IF saved_record = total_fields
  1347.               GO saved_record - 1
  1348.             IF ar_index > 1
  1349.                 ar_index = ar_index - 4
  1350.             ENDIF
  1351.         ELSE
  1352.               GO saved_record
  1353.         ENDIF
  1354.  
  1355.     ELSE
  1356.  
  1357.         APPEND BLANK
  1358.  
  1359.         REPLACE form_dbf->contents WITH SPACE(254)
  1360.     REPLACE form_dbf->header   WITH SPACE(260)
  1361.         REPLACE form_dbf->width    WITH 10
  1362.         REPLACE form_dbf->totals   WITH "N"
  1363.         REPLACE form_dbf->decimals WITH  0
  1364.  
  1365.     ENDIF
  1366.  
  1367.     IF total_fields > 1
  1368.         total_fields = total_fields - 1
  1369.         frm_colcount = frm_colcount - 1
  1370.     ENDIF
  1371.  
  1372.     * get the new data
  1373.     m_contents = form_dbf->contents
  1374.     m_width    = form_dbf->width
  1375.     m_decimals = form_dbf->decimals
  1376.     m_totals   = form_dbf->totals
  1377.  
  1378.     my_update = .T.        // generates an update...
  1379.  
  1380. ELSE    // field content is not empty, error
  1381.  
  1382.     * honk 
  1383.     ?? CHR(7)
  1384.  
  1385.     * display the error msg
  1386.     @ 24,CENTER(content_error,80) SAY content_error
  1387.     INKEY(4)
  1388. ENDIF
  1389.  
  1390. RETURN
  1391. // end of form_delete (procedure)
  1392.  
  1393. ***
  1394. *    form_goto (procedure)
  1395. *
  1396. *    goto specified field (F7)
  1397. ***
  1398. PROCEDURE form_goto
  1399.  
  1400. PRIVATE goto_str, goto_field, goto_error, goto_ok, recno_saved
  1401.  
  1402. * for this procedure only
  1403. SET CONFIRM ON
  1404.  
  1405. goto_str   = "Go to field number "
  1406. goto_error = "(Field not in valid range.  Range is 1 to 24)."
  1407. goto_field = RECNO()
  1408.  
  1409. goto_ok = .F.
  1410. DO WHILE !goto_ok
  1411.  
  1412.     @ 24,0
  1413.     @ 24,20 SAY goto_str
  1414.     @ 24,39 GET goto_field PICTURE "99"
  1415.     READ
  1416.  
  1417.    * abort if <esc> key was hit
  1418.    IF LASTKEY() == 27
  1419.       RETURN   
  1420.    ENDIF
  1421.  
  1422.    * save, to restore if error (eof)
  1423.    recno_saved = RECNO()
  1424.  
  1425.    * first check
  1426.    GO goto_field
  1427.  
  1428.    * entry ok?
  1429.    IF goto_field <= 0 .OR. goto_field >= 25 .OR. EOF()
  1430.         @ 24,CENTER(goto_error,80) SAY goto_error
  1431.         INKEY(4)
  1432.       IF EOF()
  1433.          GO recno_saved
  1434.       ENDIF
  1435.     ELSE
  1436.         goto_ok = .T.
  1437.     ENDIF
  1438.  
  1439. ENDDO
  1440.  
  1441. // new field position
  1442. GO goto_field
  1443.  
  1444. // set ar_index to new position
  1445. ar_index = (goto_field * 4) - 3
  1446.  
  1447. // the data of the new position
  1448. m_contents = form_dbf->contents
  1449. m_width    = form_dbf->width
  1450. m_decimals = form_dbf->decimals
  1451. m_totals   = form_dbf->totals
  1452.  
  1453. // set back to default
  1454. SET CONFIRM OFF
  1455.  
  1456. RETURN
  1457. // end of form_goto (procedure)
  1458.  
  1459. ***
  1460. *    clear_gets (procedure)
  1461. *
  1462. *    exit read
  1463. ***
  1464. PROCEDURE clear_gets
  1465. PARAMETERS dummy1,dummy2,dummy3
  1466.  
  1467. IF form_state = 3    // break out of loop when in fields procedure only
  1468.     break_out = .T.
  1469. ENDIF
  1470. CLEAR GETS
  1471. RETURN
  1472. // end of clear_gets (procedure)
  1473.  
  1474. ***
  1475. * form_layout (procedure)
  1476. *
  1477. * display the pageheading and items related to report layout
  1478. ***
  1479. PROCEDURE form_layout
  1480.  
  1481. FRM_SCR(1)
  1482.  
  1483. SET CURSOR ON
  1484.  
  1485. SET KEY -4 TO     // no delete option
  1486. SET KEY -5 TO  // no insert option
  1487. SET KEY -6 TO    // no goto option here
  1488. SET KEY -1 TO    // disable this option
  1489.  
  1490. @ 06,12 GET phdr_lines[1]
  1491. @ 07,12 GET phdr_lines[2]
  1492. @ 08,12 GET phdr_lines[3]
  1493. @ 09,12 GET phdr_lines[4]
  1494.     
  1495. @ 12,42 GET frm_pagewidth PICTURE "999"
  1496. @ 13,42 GET frm_leftmarg  PICTURE "999"
  1497. @ 14,42 GET frm_rightmarg PICTURE "999"
  1498. @ 15,42 GET frm_linespage PICTURE "999"
  1499. @ 16,42 GET frm_dblspaced PICTURE "!"
  1500.             
  1501. @ 20,49 GET frm_pebp      PICTURE "!"
  1502. @ 21,49 GET frm_peap      PICTURE "!"
  1503. @ 22,49 GET frm_plainpage PICTURE "!"
  1504.             
  1505. READ
  1506.  
  1507. IF UPDATED()
  1508.     my_update = .T.
  1509. ENDIF
  1510.  
  1511. RETURN
  1512. // end of form_layout (procedure)
  1513.  
  1514. ***
  1515. * form_groups (procedure)
  1516. *
  1517. * display the group and subgroup headers, plus summary and eject options
  1518. ***
  1519. PROCEDURE form_groups
  1520.  
  1521. FRM_SCR(2)
  1522.  
  1523. SET CURSOR ON
  1524.  
  1525. SET KEY -4 TO     // no delete option here
  1526. SET KEY -5 TO  // no insert option here
  1527. SET KEY -6 TO    // no goto option here
  1528.  
  1529. SET KEY -2 TO    // disable this option
  1530.  
  1531. @ 06,25 GET frm_grpexpr PICTURE "@S50"
  1532. @ 07,25 GET frm_grphdr
  1533.  
  1534. @ 11,23 GET frm_summary PICTURE "!"
  1535. @ 12,23 GET frm_pe PICTURE "!"
  1536.  
  1537. @ 18,25 GET frm_subexpr PICTURE "@S50"
  1538. @ 19,25 GET frm_subhdr
  1539.  
  1540. READ    
  1541.     
  1542. IF UPDATED()
  1543.     my_update = .T.
  1544. ENDIF
  1545.  
  1546. RETURN
  1547. // end of form_groups (procedure)
  1548.  
  1549. ***
  1550. * frm_scr (function)
  1551. *
  1552. * draw the report screens, indicated by parameter 'screen'
  1553. ***
  1554. FUNCTION FRM_SCR
  1555. PARAMETERS screen
  1556.  
  1557. PRIVATE pagehead, field_def, group, sub_group, m_exit, m_nogo
  1558. PRIVATE m_f1, m_f2, m_f3, m_f4, m_f5, m_f6, m_f10, m_layout, m_groups, m_fields
  1559. PRIVATE m_insert, m_delete, m_help
  1560.  
  1561. pagehead  = "═══ Page Header ═══"
  1562. field_def = "═══ Column Definitions ═══"
  1563. group     = "═══ Group Specifications ═══"
  1564. sub_group = "═══ Sub-Group Specifications ═══"
  1565.  
  1566. m_f1  = "F1"
  1567. m_f2  = "F2"
  1568. m_f3  = "F3"
  1569. m_f4  = "F4"
  1570. m_f5  = "F5"
  1571. m_f6  = "F6"
  1572. m_f7  = "F7"
  1573. m_f10 = "F10"
  1574.  
  1575. m_help   = "Help  "
  1576. m_layout = "Report"         // "Layout"
  1577. m_groups = "Groups"
  1578. m_fields = "Columns"        //    "Fields"
  1579. m_delete = "Delete"
  1580. m_insert = "Insert"
  1581. m_goto   = "Go To "
  1582. m_exit   = "Exit  "
  1583. m_nogo   = "...    "
  1584.  
  1585. CLEAR
  1586.  
  1587. // Display menu line.
  1588. @ 00,01 SAY m_f1
  1589. @ 00,11 SAY m_f2
  1590. @ 00,21 SAY m_f3
  1591. @ 00,31 SAY m_f4
  1592. @ 00,41 SAY m_f5
  1593. @ 00,51 SAY m_f6
  1594. @ 00,61 SAY m_f7
  1595. @ 00,70 SAY m_f10
  1596.  
  1597. @ 01,01 SAY m_help
  1598. @ 01,11 SAY m_layout
  1599. @ 01,21 SAY m_groups
  1600. @ 01,31 SAY m_fields
  1601. @ 01,41 SAY m_delete
  1602. @ 01,51 SAY m_insert
  1603. @ 01,61 SAY m_goto
  1604. @ 01,70 SAY m_exit
  1605.  
  1606. @ 02,00 SAY REPLICATE(CHR(196),80)
  1607.  
  1608. DO CASE
  1609.  
  1610.     CASE screen == 1
  1611.         * Page definition screen.
  1612.  
  1613.         @ 01,11 SAY m_nogo   // this option 'disabled'
  1614.         @ 01,41 SAY m_nogo     // delete 'disabled'
  1615.         @ 01,51 SAY m_nogo   // insert 'disabled'
  1616.         @ 01,61 SAY m_nogo     // go to  'disabled'
  1617.  
  1618.         @ 03,80-LEN("File " + form_file) SAY "File " + form_file
  1619.  
  1620.         @ 04,30 SAY pagehead
  1621.  
  1622.         @ 11,27 SAY "Formatting "
  1623.     
  1624.         @ 12,27 SAY "Page Width"
  1625.         @ 13,27 SAY "Left Margin"
  1626.         @ 14,27 SAY "Right Margin"
  1627.         @ 15,27 SAY "Lines Per Page"
  1628.         @ 16,27 SAY "Double Spaced?"
  1629.     
  1630.         @ 19,24 SAY "Printer Directives"
  1631.  
  1632.         @ 20,24 SAY "Page Eject Before Print"
  1633.         @ 21,24 SAY "Page Eject After Print"
  1634.         @ 22,24 SAY "Plain Page"
  1635.  
  1636.     CASE screen == 2
  1637.         * Group definition screen.
  1638.  
  1639.         @ 01,21 SAY m_nogo   // this option 'disabled'
  1640.         @ 01,41 SAY m_nogo    // delete 'disabled'
  1641.         @ 01,51 SAY m_nogo   // insert 'disabled'
  1642.         @ 01,61 SAY m_nogo    // go to  'disabled'
  1643.  
  1644.         @ 03,80-LEN("File " + form_file) SAY "File " + form_file
  1645.  
  1646.         @ 04,CENTER(group,80) SAY group
  1647.  
  1648.         @ 06,0 SAY "Group On Expression"
  1649.         @ 07,0 SAY "Group Heading" 
  1650.  
  1651.         @ 11,0 SAY "Summary Report Only"
  1652.         @ 12,0 SAY "Page Eject After Group"
  1653.  
  1654.         @ 16,CENTER(sub_group, 80) SAY sub_group
  1655.  
  1656.         @ 18,0 SAY "Sub-Group On Expression"
  1657.         @ 19,0 SAY "Sub-Group Heading"
  1658.  
  1659.     CASE screen == 3
  1660.  
  1661.         * Column definition screen.
  1662.         @ 03,80-LEN("File " + form_file) SAY "File " + form_file
  1663.         @ 01,31 SAY m_nogo
  1664.  
  1665.         @ 05,CENTER(field_def, 80) SAY field_def
  1666.  
  1667.         @ 07,00 SAY "Contents"
  1668.         @ 10,00 SAY "Heading"
  1669.  
  1670.         @ 11,06 SAY "1"
  1671.         @ 12,06 SAY "2"
  1672.         @ 13,06 SAY "3"
  1673.      @ 14,06 SAY "4"
  1674.         @ 18,00 SAY "Formatting"
  1675.  
  1676.         @ 19,00 SAY "Width"
  1677.         @ 20,00 SAY "Decimals"
  1678.         @ 21,00 SAY "Totals"
  1679.  
  1680. ENDCASE
  1681.  
  1682. RETURN ("")
  1683. // end of frm_scr (function)
  1684.  
  1685. ***
  1686. * frm_error (function)
  1687. *
  1688. * display the report file errors
  1689. ****
  1690. FUNCTION FRM_ERROR
  1691. PARAMETERS fname, dos_error
  1692.  
  1693. PRIVATE err_str, dos_code
  1694.  
  1695. dos_code = LTRIM(STR(dos_error))
  1696.  
  1697. DO CASE
  1698.  
  1699.     CASE dos_error == -3        // eof while reading
  1700.          err_str = "Code " + dos_code + " " + "eof while reading report " + fname
  1701.  
  1702.     CASE dos_error == -2        // disk full
  1703.          err_str = "Code " + dos_code + " " + "disk full saving report " + fname
  1704.  
  1705.     CASE dos_error == -1        // not a report file
  1706.          err_str = "Code " + dos_code + " " + "not a report file " + fname
  1707.  
  1708.     CASE dos_error == 2        // Open error, file not found
  1709.          err_str = "Code " + dos_code + " " + "error opening report " + fname
  1710.  
  1711.     CASE dos_error == 6        // Close error, invalid handle
  1712.         err_str = "Code " + dos_code + " " + "error closing report " + fname
  1713.  
  1714.    CASE dos_error == 25   // Seek error, FSEEK
  1715.         err_str = "Code " + dos_code + " " + "error seeking report " + fname
  1716.  
  1717.     CASE dos_error == 29        // Write error, write fault
  1718.         err_str = "Code " + dos_code + " " + "error writing report " + fname
  1719.  
  1720.     CASE dos_error == 30        // Read error, read fault
  1721.         err_str = "Code " + dos_code + " " + "error reading report " + fname
  1722.  
  1723.   OTHERWISE
  1724.         err_str = "Code " + dos_code + " " + "see DOS extended error codes"
  1725.  
  1726. ENDCASE
  1727.  
  1728. @ 24,CENTER(err_str,80) SAY err_str
  1729. INKEY(4)
  1730. @ 24,0
  1731.  
  1732. RETURN ("")
  1733. // end of frm_error (function)
  1734.  
  1735. ***
  1736. * lbl_error (function)
  1737. *
  1738. * display the label file errors
  1739. ***
  1740. FUNCTION LBL_ERROR
  1741. PARAMETERS fname, dos_error
  1742.  
  1743. PRIVATE err_str, dos_code
  1744.  
  1745. dos_code = LTRIM(STR(dos_error))
  1746.  
  1747. DO CASE
  1748.  
  1749.     CASE dos_error == -3        // eof while reading
  1750.          err_str = "Code " + dos_code + " " + "eof while reading label " + fname
  1751.  
  1752.     CASE dos_error == -2        // disk full
  1753.          err_str = "Code " + dos_code + " " + "disk full saving label " + fname
  1754.  
  1755.     CASE dos_error == -1        // not a label file
  1756.          err_str = "Code " + dos_code + " " + "not a label file " + fname
  1757.  
  1758.     CASE dos_error == 2        // Open error, file not found
  1759.          err_str = "Code " + dos_code + " " + "error opening label " + fname
  1760.  
  1761.     CASE dos_error == 6        // Close error, invalid handle
  1762.         err_str = "Code " + dos_code + " " + "error closing label " + fname
  1763.  
  1764.    CASE dos_error == 25   // Seek error, FSEEK
  1765.         err_str = "Code " + dos_code + " " + "error seeking label " + fname
  1766.  
  1767.     CASE dos_error == 29        // Write error, write fault
  1768.         err_str = "Code " + dos_code + " " + "error writing label " + fname
  1769.  
  1770.     CASE dos_error == 30        // Read error, read fault
  1771.         err_str = "Code " + dos_code + " " + "error reading label " + fname
  1772.  
  1773.   OTHERWISE
  1774.         err_str = "Code " + dos_code + " " + "see DOS extended error codes"
  1775.  
  1776. ENDCASE
  1777.  
  1778. @ 24,CENTER(err_str,80) SAY err_str
  1779. INKEY(4)
  1780. @ 24,0
  1781.  
  1782. RETURN ("")
  1783. // end of lbl_error (function)
  1784.  
  1785. ***
  1786. * center (function)
  1787. *
  1788. * center a string
  1789. ***
  1790. FUNCTION CENTER
  1791. PARAMETER string,length
  1792. RETURN INT((length-LEN(string))/2)
  1793.  
  1794. //**
  1795. // ext_add (function)
  1796. //
  1797. // append an .FRM/.LBL extension if one was not found
  1798. //**
  1799. FUNCTION EXT_ADD
  1800. PARAMETERS fname, type
  1801.  
  1802. PRIVATE open
  1803.  
  1804. IF AT(".", fname) == 0
  1805.     IF type == "L"
  1806.         open = TRIM(fname) + ".LBL"
  1807.     ENDIF
  1808.     IF type == "R"
  1809.         open = TRIM(fname) + ".FRM"
  1810.     ENDIF
  1811. ELSE
  1812.     open = TRIM(fname)
  1813. ENDIF
  1814.  
  1815. RETURN (open)
  1816. // end of ext_add (function)
  1817.  
  1818. ***
  1819. * Xlate()
  1820. *    Translate the semicolons
  1821. * 
  1822. ***
  1823. FUNCTION XLATE
  1824. PARAMETERS source, char, len
  1825.  
  1826. PRIVATE xlated_str
  1827.  
  1828. fend_pos = AT(char, SUBSTR(source, fstart_pos, len))
  1829.  
  1830. IF fend_pos = 0
  1831.     xlated_str = SUBSTR(source, fstart_pos, len)
  1832.     fstart_pos = fstart_pos + LEN(xlated_str)
  1833. ELSE
  1834.     xlated_str = SUBSTR(source, fstart_pos, fend_pos - 1)
  1835.     fstart_pos = fstart_pos + LEN(xlated_str) + 1
  1836. ENDIF
  1837.  
  1838. // pad string with spaces when needed
  1839. IF LEN(xlated_str) != len
  1840.     xlated_str = xlated_str + SPACE(len - LEN(xlated_str))
  1841. ENDIF
  1842.  
  1843. RETURN (xlated_str)
  1844.