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