home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / basic1 / pro10 / fed-demo.bas < prev    next >
Encoding:
BASIC Source File  |  1988-12-14  |  15.7 KB  |  516 lines
  1. '      FED - DEMO
  2. '  Version II - demonstrates the use of a LEVEL parameter
  3. '               to handle an entire record I/O in a loop and
  4. '               one or 2 fed CALLS - NO GOTOs!!!!!
  5. '
  6. '  Text input demo
  7. '  Demonstrates the use of FED and several other GLib routines
  8. '
  9. '  Author: Gizmo Mike
  10. '  (C) InfoSoft, 1987, 1988, 1989
  11. '
  12.  
  13.  
  14. ' define named common block for most FED variables
  15. '
  16. COMMON /fedvars/ fg%, bg%, fgd%, bgd%, alarm%, edited%, nums%, num$, upcase%
  17.  
  18. DECLARE SUB SvScrn (SEG arry%)
  19. DECLARE SUB RstScrn (SEG arry%)
  20.  
  21.  
  22.     CLEAR
  23.     DEFINT A-Z
  24.     OPTION BASE 1
  25.  
  26.  
  27.     TYPE structure                   ' set up employee structure
  28.        NName AS STRING * 25
  29.        Phone AS STRING * 8
  30.        Addr AS STRING * 25
  31.        City AS STRING * 10
  32.        State AS STRING * 2
  33.        Zip AS STRING * 5
  34.        Dept AS STRING * 6
  35.        Superv AS STRING * 12
  36.        PFreq AS STRING * 1
  37.        PRate AS SINGLE
  38.        PIN AS INTEGER
  39.     END TYPE
  40.  
  41.     DIM Emp AS structure             ' DIM emp as TYPE struct
  42.  
  43.     REDIM a$(11)                     ' temp holding for emp structures
  44.  
  45.     'make sure it is set up right
  46.     CLS : SOUND 750, 2: LOCATE 5, 5
  47.     PRINT "Depending on your display, you may want to restart this demo"
  48.     LOCATE 7, 5
  49.     PRINT "with the command line parameter [/CMD /NC] or [/CMD /C]. /NC for"
  50.     LOCATE 9, 5
  51.     PRINT "No Color, /C for color version."
  52.     LOCATE 13, 5
  53.     PRINT "Tap `S' to stop the demo, any other key to continue."
  54.  
  55.     GOSUB WaitKey
  56.  
  57.     IF ky$ = "S" OR ky$ = "s" THEN
  58.        SYSTEM
  59.     END IF
  60.  
  61.     '*********** get command line parms and set colors
  62.     DIM arg$(2): q% = 0
  63.     CALL CmdLine(arg$(), q%)
  64.  
  65.     IF arg$(1) = "/NC" THEN           ' find out if command line wants color
  66.        fg = 7: bg = 0
  67.        fge = 15: bge = 0
  68.        fgw = 0: bgw = 7
  69.        fgd = 15: bgd = 0
  70.        fgh = 7: bgh = 15
  71.        fgb = 15: bgb = 0
  72.        fgt = 7: bgt = 0
  73.     ELSE
  74.        fg = 2: bg = 0                    ' general colors
  75.        fge = 12: bge = 3                 ' err message colors
  76.        fgw = 14: bgw = 4                 ' window colors
  77.        fgd = 10: bgd = 0                 ' data colors
  78.        fgh = 15: bgh = 1                 ' help colors
  79.        fgb = 4: bgb = 0                  ' box color
  80.        fgt = 3: bgt = 0                  ' text colors
  81.     END IF
  82.  
  83.     eattr = (bge * 16) + fge              ' error message attributes
  84.     wattr = (bgw * 16) + fgw              ' window attributes
  85.     hattr = (bgh * 16) + fgh              ' help window attributes
  86.  
  87.     CALL WShadow(1)
  88.  
  89.     Adding = 0
  90.  
  91.     REM $DYNAMIC
  92.     REDIM Sarry(4000)                     ' dimension screen array for 2 screens
  93.  
  94.  
  95.     DIM hlp$(10)      ' String array to hold help screen msgs for use later.
  96.                   ' Has to be DIMmed in code prior to other references
  97.                   ' to hlp$().
  98.  
  99.     hlp$(1) = "Home - Start of line             End - End of line"
  100.     hlp$(2) = "  "
  101.     hlp$(3) = "Ctrl-X  Clear Field      Ctrl-End  Clear to end of line"
  102.     hlp$(4) = "Ctrl-U  Undo             <Arrows> Fwd, Bkwd 1 field "
  103.     hlp$(5) = "  "
  104.     hlp$(6) = "       PgUp / Ctrl PgUp - Jump to first field "
  105.     hlp$(7) = "       PgDn / Ctrl PgDn - Jump to last field  "
  106.     hlp$(8) = "  "
  107.     hlp$(9) = "[Esc] or [F9] Aborts Current Edit      [F10] Save Record"
  108.  
  109.     hlp$(10) = "[ Tap any key to continue ]"
  110.  
  111.  
  112.  
  113. prg.start:              '*************** start of program  *****************
  114.     GOSUB GenDisp                        ' put screen mask on screen
  115.     CALL SvScrn(Sarry(1))                ' save it - RSTSCRN is quicker next time
  116.  
  117.     GOSUB OpenFil                        ' open the file
  118.  
  119.     IF hi = 0 THEN                       ' in case you lost the EMP.DAT file
  120.        GOSUB newfil
  121.     END IF
  122.     recno = hi                           ' get the top rec no
  123.  
  124.     GOSUB RecDisp                        ' display given record
  125.  
  126.  
  127. '----------------------------------------------------------------------------
  128. '  This is one big loop with several SELECT CASE constructs in it.
  129. '
  130. '  One CASE construct sets the level or a pointer to the field that we
  131. '  are currently editing.
  132. '
  133. '  Based on that level, another CASE construct sets the FED parameters
  134. '  for the next call.  ie if we are on level 2 (phone), then we need to
  135. '  set nums ON. 
  136. '
  137. '  One other CASE block intercepts those fields that need further data
  138. '  verification and perfomrs that check.
  139. '
  140. '  The data is read from file into the TYPE structure and then stored
  141. '  in a string array for the level pointer indexing, then stored BACK
  142. '  to the TYPE structure for saving to disk.  You should not perform
  143. '  I/O directly on TYPE elements.
  144.  
  145. '  The random access file code contained here is pretty minimal - just
  146. '  enough to be able to demo FED.    In a "real" random file application,
  147. '  there are a number of things that should be done in the way of checking
  148. '  for valid data, also, there are  functions missing like to delete a
  149. '  record (missing because it does not lend itself to demoing FED or GLIB
  150. '  - this is not a QB tutor!).
  151. '  There ARE several other GLIB functions used:
  152. '  ERRMSG, DLRFRMAT, NFRMAT, WDW and a few others.        
  153. '---------------------------------------------------------------------------
  154.  
  155.     level = 1                           ' indicates active FIELD in record
  156.     fsiz = 25                 ' first field siz
  157.     rx = 4                    ' input location
  158.     ry = 10
  159.     alarm = 1                 ' beeper on
  160.     done = 0
  161.  
  162.     DO
  163.        LOCATE rx, ry                   ' locate current location
  164.        PRINT a$(level)                 ' print string
  165.        LOCATE rx, ry                   ' reset to SOS
  166.  
  167.        CALL Fed(a$(level), fsiz, Fcode)
  168.  
  169.        ' first, we want to intercept the 2 numeric inputs and
  170.        ' check them.  All validity checking would go here.
  171.  
  172.        SELECT CASE level
  173.           CASE 2                    ' check the phone
  174.              temp$ = a$(2)
  175.  
  176.              DO
  177.                 m = 2: p = 0          ' m sets NFRMAT mode, p is useless here
  178.                 CALL nfrmat(temp$, m, p)
  179.                 IF m <> 2 THEN         '  something went wrong !!
  180.                     ' tell them of error
  181.                     CALL ERRMSG(temp$, 24, eattr%, 2)
  182.                     temp$ = a$(2)
  183.                     LOCATE rx, ry
  184.                     CALL Fed(temp$, fsiz, Fcode)
  185.                 END IF
  186.              LOOP UNTIL m = 2
  187.              a$(2) = temp$
  188.  
  189.           CASE 9
  190.              IF INSTR("HS", a$(9)) = 0 THEN
  191.                 CALL ERRMSG("Pay Frequency code must be H or S only.", 24, eattr%, 2)
  192.                 ret$ = " "
  193.                 CALL GetCH("HS", ret$)   ' mask the input
  194.                 a$(9) = ret$
  195.               END IF
  196.  
  197.           CASE 10
  198.              temp$ = a$(10)
  199.              DO
  200.                 m = 0: p = 2        ' set up for dollar formatting call
  201.                 CALL dlrfrmat(temp$, m%, p%)
  202.  
  203.                 IF m <> 0 THEN                   ' if m is changed
  204.                     CALL ERRMSG(temp$, 24, eattr, 2)
  205.                     temp$ = a$(10)
  206.                     LOCATE rx, ry
  207.                     CALL Fed(temp$, fsiz, Fcode)
  208.                 END IF
  209.              LOOP UNTIL m = 0
  210.  
  211.           CASE ELSE
  212.        END SELECT
  213.  
  214.  
  215.  
  216.        SELECT CASE Fcode                ' handle the exit return first
  217.           CASE 0, 6                    ' down = enter for this
  218.              level = level + 1
  219.  
  220.              ' "wrap" from last to first field
  221.              IF level > UBOUND(a$) THEN level = 1
  222.  
  223.  
  224.           CASE 5                       ' UP
  225.              IF level - 1 > 0 THEN
  226.                 level = level - 1
  227.              END IF
  228.  
  229.           CASE 1                        ' F1 key pressed (HELP)
  230.              CALL SvScrn(Sarry(2001))         ' save screen as is
  231.              CALL wdw(7, 12, 17, 72, 1, 1, 2, hattr, "Editing Help")
  232.  
  233.              FOR x = 1 TO 9                   ' pop help window up
  234.                 CALL quikprt(hlp$(x), 7 + x, 14, hattr%)
  235.              NEXT x                           ' QUIKPRT help msgs
  236.              LOCATE 18, 30: COLOR fgh, bgh: PRINT hlp$(10)
  237.  
  238.              GOSUB WaitKey                    ' wait for any key
  239.              CALL RstScrn(Sarry(2001))        ' restore pre help screen
  240.  
  241.  
  242.           CASE 3, 4                     ' F3 page back a record. F$ = FORWARD
  243.              IF edited THEN                   ' they have changed something
  244.                 CALL ERRMSG("You cannot PAGE until current edit is saved.", 24, eattr%, 2)
  245.              END IF
  246.  
  247.              IF Fcode = 3 THEN
  248.                 IF recno > 1 THEN recno = recno - 1      ' back up a record
  249.              ELSE
  250.                 IF recno < hi THEN recno = recno + 1     ' forward a record   
  251.              END IF
  252.  
  253.              CALL RstScrn(Sarry(1))           ' restore blank screen (bleed thru)
  254.              GOSUB RecDisp                    ' display desired record
  255.              level = 1                        ' set to start with name
  256.  
  257.  
  258.           CASE 7                                  ' F7 add a record
  259.              IF edited <> 0 THEN
  260.                 CALL ERRMSG("Cannot ADD until current EDIT is saved.", 24, eattr, 2)
  261.              ELSE
  262.                 IF Adding THEN           ' this is a toggle
  263.                     Adding = 0
  264.                 ELSE
  265.                     Adding = 1
  266.                     REDIM a$(11)         ' clear out what is in there
  267.                 END IF
  268.              END IF
  269.  
  270.              IF Adding THEN
  271.                 recno = hi + 1           ' increment record pointer
  272.  
  273.                 CALL RstScrn(Sarry(1))   ' show input screen mask
  274.                 GOSUB show.rec           ' display it
  275.  
  276.                 ' change display to show how to STOP adding
  277.                 COLOR fgt
  278.                 LOCATE 19, 10: PRINT "[F1] - Help         [F7] - Stop Adding        [F10] - Save"
  279.                 COLOR fg
  280.                 SOUND 1500, .3
  281.                 level = 1
  282.              ELSE
  283.                 COLOR fgt
  284.                 LOCATE 19, 10: PRINT "[F1] - Help         [F7] - Add record         [F10] - Save"
  285.                 COLOR fg
  286.                 SOUND 1500, .3      ' get their attention that F7
  287.                                 ' function changed
  288.                 CLOSE
  289.                 GOSUB OpenFil       ' get top record number
  290.                 recno = hi
  291.                 GOSUB RecDisp       ' display highest Record
  292.                 level = 1
  293.              END IF
  294.  
  295.  
  296.           CASE 8                      ' F8 - quit demo
  297.              CLOSE
  298.              SYSTEM
  299.  
  300.  
  301.           CASE 9, 15                  ' F9, ESC
  302.              recno = 1                   ' this should have a "ARE YOU SURE"
  303.              level = 1
  304.              GOSUB RecDisp               ' prompt if it was more than demo
  305.                           
  306.           CASE 10                         ' F10 save record
  307.              GOSUB closefil              ' Put rec to file and close it
  308.              edited = 0                  ' reset the edit flag
  309.              GOSUB show.rec              ' show the new version
  310.              level = 1
  311.  
  312.  
  313.           CASE 11, 13                     'Pg Up or ^Pg Up
  314.               level = 1
  315.  
  316.           CASE 12, 14                     'Pg Dn or ^Pg Dn
  317.               level = UBOUND(a$)         ' set to edit LAST field
  318.  
  319.           CASE ELSE                        ' handles all other fed codes
  320.  
  321.        END SELECT
  322.  
  323.        nums = 0
  324.        upcase = 0
  325.  
  326.  
  327.        SELECT CASE level         ' now set FED variables/based on next field
  328.           CASE 1
  329.              rx = 4: ry = 10: fsiz = 25: upcase = 1
  330.           CASE 2
  331.              rx = 4: ry = 57: fsiz = 8: nums = 1: num$ = "1234567890-"
  332.  
  333.           CASE 3
  334.              rx = 6: ry = 13: alarm = 1: fsiz = 25
  335.           CASE 4
  336.              rx = 8: ry = 10: alarm = 1: fsiz = 10
  337.           CASE 5
  338.              rx = 8: ry = 42: alarm = 0: fsiz = 2
  339.           CASE 6
  340.              rx = 8: ry = 60: alarm = 0: fsiz = 5
  341.              nums = 1: num$ = "1234567890"
  342.           CASE 7
  343.              rx = 12: ry = 16: alarm = 1: fsiz = 6
  344.           CASE 8
  345.              rx = 12: ry = 57: alarm = 1: fsiz = 12
  346.           CASE 9
  347.              rx = 14: ry = 41: alarm = 1: fsiz = 1: nums = 1
  348.              num$ = "1234567890"
  349.  
  350.           CASE 10
  351.              rx = 14: ry = 70: alarm = 0: fsiz = 6: nums = 1
  352.              num$ = "1234567890.$"
  353.  
  354.           CASE 11
  355.              rx = 16: ry = 17: alarm = 0: fsiz = 4: nums = 1
  356.              num$ = "1234567890"
  357.             
  358.           CASE ELSE
  359.        END SELECT
  360.     LOOP UNTIL done
  361.  
  362.  
  363.  
  364.     SYSTEM
  365.  
  366. '================================[ SUBROUTINES ]==============================
  367.  
  368. OpenFil:         '-----------   open demo file statements  ---------
  369.     OPEN "emp.dat" FOR RANDOM AS #1 LEN = LEN(Emp)
  370.     sof = LOF(1) / LEN(Emp)               ' sof is number of records in file
  371.     hi = sof                              ' hi is high record number
  372. RETURN
  373.  
  374.  
  375. closefil:       '-------------   store the record ---------------
  376.     IF edited OR Adding THEN       'no need to save if not changed !
  377.        Emp.NName = a$(1)
  378.        Emp.Phone = a$(2)
  379.        Emp.Addr = a$(3)
  380.        Emp.City = a$(4)
  381.        Emp.State = a$(5)
  382.        Emp.Zip = a$(6)
  383.  
  384.        Emp.Dept = a$(7)
  385.        Emp.Superv = a$(8)
  386.        Emp.PFreq = a$(9)
  387.        Emp.PRate = VAL(a$(10))
  388.        Emp.PIN = VAL(a$(11))
  389.  
  390.        PUT #1, recno, Emp                  ' move record to buffer
  391.        CLOSE #1                            ' actually put file to disk
  392.        GOSUB OpenFil                       ' open file again in updated state
  393.        edited = 0
  394.     END IF
  395. RETURN
  396.  
  397.  
  398.          '---------- put selected record to the screen  -----------
  399. RecDisp:          
  400.                ' convert to memory variable to edit a COPY
  401.                ' of each and strip trailing blanks, assign to temp
  402.                ' array storage
  403.     GET #1, recno, Emp
  404.  
  405.     a$(1) = RTRIM$(Emp.NName)
  406.     a$(2) = RTRIM$(Emp.Phone)
  407.     a$(3) = RTRIM$(Emp.Addr)
  408.     a$(4) = RTRIM$(Emp.City)
  409.     a$(5) = RTRIM$(Emp.State)
  410.     a$(6) = RTRIM$(Emp.Zip)
  411.     a$(7) = RTRIM$(Emp.Dept)
  412.     a$(8) = RTRIM$(Emp.Superv)
  413.     a$(9) = RTRIM$(Emp.PFreq)
  414.  
  415.     a$(10) = LTRIM$(RTRIM$(STR$(Emp.PRate)))
  416.     CALL dlrfrmat(a$(10), 2, 2)
  417.  
  418.     a$(11) = LTRIM$(RTRIM$(STR$(Emp.PIN)))
  419.  
  420.  
  421.  
  422. show.rec:                  ' display the record
  423.     IF edited THEN                      ' This part is not critical,
  424.        COLOR bgb, fgb                 '  but shows user when current
  425.        LOCATE 1, 35                   '  record is different from data
  426.        PRINT " [ EDITING ] "          '  in file.
  427.     ELSE
  428.        COLOR fgb, bgb
  429.        LOCATE 1, 35
  430.        PRINT STRING$(15, 205);
  431.     END IF
  432.     COLOR fg, bg
  433.  
  434.  
  435.     COLOR fg, bg
  436.     LOCATE 4, 10: PRINT a$(1)
  437.     LOCATE 4, 57: PRINT a$(2)
  438.     LOCATE 6, 13: PRINT a$(3)
  439.     LOCATE 8, 10: PRINT a$(4)
  440.     LOCATE 8, 42: PRINT a$(5)
  441.     LOCATE 8, 60: PRINT a$(6)
  442.  
  443.     LOCATE 12, 16: PRINT a$(7)
  444.     LOCATE 12, 57: PRINT a$(8)
  445.     LOCATE 14, 41: PRINT a$(9)
  446.     LOCATE 14, 70: PRINT a$(10)
  447.     LOCATE 16, 17: PRINT STRING$(4, 254)
  448.     LOCATE 16, 71: COLOR fgw, 0: PRINT recno%
  449.     COLOR fg, bg
  450.     edited = 0        ' set edit flag to show that record on screen is same as file
  451.  
  452. RETURN
  453.  
  454.  
  455.  
  456. GenDisp:
  457. '---------------------------------------------------------------------------
  458. '*  Routine to put general display on the screen, this is used once.  After
  459. '*  it is put to the screen, it is saved via SVSCRN, and restored from there
  460. '*  rather than doing all these PRINTs again.                              
  461. '---------------------------------------------------------------------------
  462.  
  463.     CALL boxes(1, 1, 25, 80, 1, fgb)           ' put a big box on screen
  464.     COLOR fgt + 8
  465.     LOCATE 2, 25: PRINT "XYZ Corporation Employee Data File"      ' a title
  466.     COLOR fgt
  467.     LOCATE 4, 4: PRINT "Name: "
  468.     LOCATE 4, 50: PRINT "Phone: "
  469.     LOCATE 6, 4: PRINT "Address: "
  470.     LOCATE 8, 4: PRINT "City: "
  471.     LOCATE 8, 35: PRINT "State: "
  472.     LOCATE 8, 55: PRINT "Zip: "
  473.     LOCATE 12, 4: PRINT "Department: "
  474.     LOCATE 12, 45: PRINT "Supervisor: "
  475.     LOCATE 14, 4: PRINT "Hourly / Salary Level (H or S only): "
  476.     LOCATE 14, 60: PRINT "Pay Rate: "
  477.     LOCATE 16, 55: PRINT "Record Number: ";
  478.  
  479.  
  480.     LOCATE 16, 4: PRINT "4 Digit PIN: "
  481.     COLOR 4, 0: LOCATE 17, 1: PRINT CHR$(199) + STRING$(78, 196) + CHR$(182)
  482.     COLOR fgt + 8: LOCATE 18, 30: PRINT "Editing Keys:": COLOR fgt
  483.  
  484.     LOCATE 20, 10: PRINT "       [F8] - Quit                   [F9] - Abort Edit"
  485.     LOCATE 19, 10: PRINT "[F1] - Help         [F7] - Add Record         [F10] - Save"
  486.  
  487.     LOCATE 21, 10: PRINT "[F3] - Page back one record   [F4] - Page forward one record"
  488.     LOCATE 22, 10: PRINT "[Enter] - Advances a field.   [PgDn] - Jump to last field"
  489.     LOCATE 23, 5: PRINT "[PgUp] - Jump to first field   <Arrow Keys> Advance or back up one field."
  490.  
  491.   RETURN
  492.  
  493.  
  494.  
  495. newfil:       '---------------- make a new file if demo one got lost  -------
  496.    a$(1) = "JIM LOTUS"
  497.    a$(2) = "555-0123"
  498.    a$(3) = "1432 OAK STREET"
  499.    a$(4) = "CENTERVILE"
  500.    a$(5) = "MA"
  501.    a$(6) = "01234"
  502.    a$(7) = "EXEC."
  503.    a$(8) = "NONE"
  504.    a$(9) = "S"
  505.    a$(10) = "900.00"
  506.    a$(111) = "1234"
  507.  
  508.    recno = 1
  509.    GOSUB closefil
  510. RETURN
  511.  
  512. WaitKey:             '--------loop until a key is pressed - handy to have
  513.     ky$ = INPUT$(1)
  514. RETURN
  515.  
  516.