home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / pb / library4 / fentry-u.bas < prev    next >
BASIC Source File  |  1990-09-16  |  22KB  |  782 lines
  1.  
  2.  
  3. '==============================================================================
  4. '                    THE FIRST UNIT -- FENTRY.BAS
  5. '==============================================================================
  6. '                                                               -- 2-13-90
  7.                             $COMPILE UNIT
  8.                             $ERROR ALL OFF
  9.  
  10.  
  11.  DEFINT A-Z
  12.  
  13.  %False = 0
  14.  %True = NOT %False
  15.  %ReadRodent = 3
  16.  %LeftButton = 1
  17.  %RightButton = 2
  18.  %MaxDecPlaces = 4
  19.  
  20.  EXTERNAL RD$, ColorDisplay, NeedDCon
  21.  EXTERNAL BoxColor, FldColor, WinColor, ScrColor
  22.  EXTERNAL CursorTop, CursorBottom, Ln, Col
  23.  EXTERNAL PressAKeyBeep$, OopsBeep$, TinyBeep$
  24.  EXTERNAL LocalAreaCode$, Record%
  25.  
  26.  DECLARE FUNCTION FigDate& (STRING)
  27.  DECLARE FUNCTION WriteDate$ (LONG)
  28.  
  29.  DECLARE SUB CloseFiles ()
  30.  DECLARE SUB Mouse (INTEGER, INTEGER, INTEGER, INTEGER)
  31.  DECLARE SUB BOXMESSAGE2 (INTEGER, INTEGER, INTEGER, STRING ARRAY,_
  32.                                                            INTEGER, INTEGER)
  33.  DECLARE SUB SCREENPUSH ()
  34.  DECLARE SUB SCREENPOP ()
  35.  
  36.  
  37.  
  38. SUB ENTERSTRING (Wkg$,FLength,Opt$) PUBLIC
  39.  
  40. '   WHAT IS THIS ?? This routine provides a field right at the present cursor
  41. '         location for the operator to enter something into (if it starts off
  42. '         blank) or edit. Wkg$ is the current value of the field.  FLength =
  43. '         length of field.
  44. '
  45. '         Opt$ may be "" or may hold the strings "Cap" for all uppercase,
  46. '         "Auto" to automatically go on when the field is full, "UpOut" or
  47. '         "BackOut" if UpArrow or Left/ backspace keys are to be able to end
  48. '         entry; also may include "Ins" to start up in the insert mode, and/or
  49. '         "-" if the minus sign is allowed to be entered.
  50. '
  51. '         Active keys also include:  ^Y to clear the line
  52. '                                    ^T to delete one word (to right)
  53. '                                    ^U to undo (restore original string)
  54. '                                     Home, End, cursor rt/left,
  55. '                                    ^cursor (jumps to beginning of a word)
  56. '
  57. '         If there is something in the field to begin with and the operator
  58. '         starts typing something else, the field clears. If the cursor is
  59. '         moved around first, that doesn't happen.
  60. '
  61. '         On exiting sub, Opt$ will be reset as "Left", "Auto", "Up", "Down",
  62. '         "HELP!", "F2", "ESC" or "CR", "Tab" or "ShfTab" according to what
  63. '         event terminated the entry
  64. '         process. At any time during string entry the operator can press [CR] or
  65. '         DOWN-ARROW to enter; [F2] can be pressed  (I use F2 for Database
  66. '         Function commands  -- Clear, Find, Next/Prev, Save etc.) or F1 can also
  67. '         be made active (for a help key) ...
  68.  
  69.  
  70.   LOCAL Fpos, Masq$,Starting$, Numeric, Auto, Caps, UpOut, BackOut, K$,_
  71.        NoNeg, InsertStatus, Z, NumKStrokes, StartWord, EndWord, Done
  72.  
  73.  
  74.  Wkg$ = LEFT$ (Wkg$, FLength)
  75.  Starting$ = Wkg$ '                                    save starting string --
  76.   Ln = CSRLIN: Col = POS
  77. '                                         Scan the Option String for Codes ...
  78. '                                                and set flags accordingly
  79.  Numeric = INSTR(Opt$,"Num")
  80.  Auto = INSTR(Opt$,"Auto")
  81.  Caps = INSTR(Opt$,"Cap")
  82.  UpOut = INSTR(Opt$,"UpOut")
  83.  BackOut = INSTR(Opt$,"BackOut")
  84.  IF INSTR (Opt$, "-") = 0 THEN NoNeg = %True
  85.  IF INSTR (Opt$, "Ins") THEN InsertStatus = %True
  86.  
  87.  IF FLength > 1 THEN
  88.     Masq$ = "\"+SPACE$(FLength-2)+"\"
  89.  ELSEIF FLength = 1 THEN
  90.     Masq$ = "!"
  91.  ELSE
  92.     PRINT "SETUP ERROR -- STRING FIELD HAS LENGTH < 1 !!"
  93.     Done = %True
  94.  END IF
  95.  
  96.  FPos = 1
  97.  
  98. '                   ============ WRITE THE FIELD TO DISPLAY =============
  99.  DO UNTIL Done
  100.  
  101.    LOCATE Ln, Col,0 '                                   print the string
  102.    PRINT USING Masq$;Wkg$
  103. '                                    now, if you already pressed Up or ShfTab,
  104. '                                    we'll exit after printing restored line
  105.    IF Opt$ = "Up" OR Opt$ = "ShfTab" THEN EXIT LOOP
  106. '                      if "auto-CR" is on and we have reached the end, quit ...
  107.    IF Auto AND FPos > FLength THEN Opt$ = "Auto": EXIT LOOP
  108. '                     if there are trailing spaces, get rid of them
  109. '                     unless the cursor is out to the right of the last chr ...
  110.    IF FPos =< LEN(Wkg$) THEN Wkg$ = RTRIM$(Wkg$)
  111.  
  112.  '                 ================== SET CURSOR: ===========================
  113.  
  114.    IF ColorDisplay THEN
  115.      LOCATE Ln,(Col+FPos-1),1,(6+2*InsertStatus),7
  116.    ELSE
  117.      LOCATE Ln,(Col+FPos-1),1,(11+4*InsertStatus),12
  118.    END IF
  119.  
  120.    DO:LOOP UNTIL INSTAT '                   ****************************
  121.    K$ = INKEY$  '                          **   RECEIVE KEYPRESS ...   **
  122.  '                                          ****************************
  123.  
  124.  
  125.    INCR NumKStrokes
  126.  
  127.  
  128.    SELECT CASE K$
  129.  
  130.       CASE CHR$(0)+CHR$(&H48)
  131.          GOSUB EUpArrow
  132.          IF Done THEN EXIT LOOP
  133.  
  134.       CASE CHR$(0)+CHR$(&H4B)
  135.          GOSUB ELeftArrow
  136.          IF Done THEN EXIT LOOP
  137.  
  138.       CASE CHR$(0)+CHR$(&H4D)
  139.          GOSUB ERightArrow
  140.          IF Done THEN EXIT LOOP
  141.  
  142.       CASE CHR$(0)+CHR$(&H50)
  143.          GOSUB EDownArrow
  144.          IF Done THEN EXIT LOOP
  145.  
  146.       CASE CHR$(0)+CHR$(&H47)
  147.          GOSUB EHomeKey
  148.  
  149.       CASE CHR$(0)+CHR$(&H4F)
  150.          GOSUB EEndKey
  151.  
  152.       CASE CHR$(0)+CHR$(&H53)
  153.          GOSUB EDelKey
  154.  
  155.       CASE CHR$(0)+CHR$(&H52)
  156.          GOSUB EInsKey
  157.  
  158.       CASE CHR$(0)+CHR$(&H3B)
  159.          GOSUB EF1Key
  160.          IF Done THEN EXIT LOOP
  161.  
  162.       CASE CHR$(0)+CHR$(&H3C)
  163.          GOSUB EF2Key
  164.          IF Done THEN EXIT LOOP
  165.  
  166.       CASE CHR$(0)+CHR$(115)
  167.          GOSUB ECtrlLeftKey
  168.  
  169.       CASE CHR$(0)+CHR$(116)
  170.          GOSUB ECtrlRightKey
  171.  
  172.       CASE CHR$(13)                'you pressed [CR]: exit w/ resulting string
  173.         Opt$ = "CR"
  174.         EXIT LOOP
  175.  
  176.       CASE CHR$(8) '                                    You pressed [BACKSPACE].
  177.          DECR FPos '                                    back up 1 space;
  178.          IF FPos < 1 THEN '                                if cursor is trying
  179.            IF BackOut THEN '                           to get out the left side
  180.              Opt$ = "Left" '                             of the box and BackOut
  181.              EXIT LOOP '                                  is on, then exit;
  182.            ELSE
  183.              FPos = 1 '  : GOTO ESetCursor (I'M ELIMINATING THE SKIPWRITE LABEL ...)
  184.            END IF
  185.          ELSE
  186.            GOSUB EDelKey '                                 else delete character.
  187.          END IF
  188.  
  189.       CASE CHR$(27)                    ' you pressed [ESC]: exit
  190.          Opt$ = "ESC"
  191.          EXIT LOOP
  192.  
  193.       CASE CHR$(9)                    ' you pressed [TAB]: exit
  194.          Opt$ = "Tab"
  195.          EXIT LOOP
  196.  
  197.       CASE CHR$(0) + CHR$(15)                    ' you pressed [ShfTAB]: exit
  198.          Opt$ = "ShfTab"
  199.          EXIT LOOP
  200.  
  201.       CASE CHR$(20)
  202.          StartWord = FPos
  203.          DO UNTIL MID$ (Wkg$,StartWord,1) = " " OR StartWord = 1
  204.            DECR StartWord
  205.          LOOP
  206.          EndWord = FPos
  207.          DO
  208.            INCR EndWord
  209.          LOOP UNTIL MID$ (Wkg$,EndWord,1) = " " OR EndWord > LEN(Wkg$)
  210.          Wkg$ = LEFT$ (Wkg$, StartWord-1) + MID$ (Wkg$, EndWord)
  211.          IF LEFT$(Wkg$,1) = " " THEN Wkg$ = MID$(Wkg$,2)
  212.          FPos = StartWord
  213.  
  214.       CASE CHR$(25)   '                                      you pressed ^Y
  215.          Wkg$ = ""
  216.          FPos = 1
  217.  
  218.       CASE CHR$(21)   '                                      you pressed ^U
  219.          Wkg$ = Starting$
  220.          FPos = 1
  221.  
  222.  CASE ELSE '                                       some other key was pressed.
  223.  
  224.  IF ((LEN(Wkg$) < FLength) OR NOT InsertStatus)_
  225.                        OR NumKStrokes = 1  THEN '  if field isn't full yet, or
  226. '                                                  INS is off, or just starting
  227.    IF  NumKStrokes = 1 THEN Wkg$ = ""
  228.                                '  this zaps the old entry if you
  229.         SELECT CASE ASC(K$) '                        start a new one ...
  230.            CASE 1 TO 31, >126
  231.              K$ = "": EXIT SELECT '                  eliminate invalid chrs ...
  232.            CASE 32 TO 44, 47, >57
  233.              IF Numeric THEN PLAY "O3 A64":K$ = "": EXIT SELECT
  234.            CASE 45
  235.              IF Numeric AND NoNeg THEN PLAY "O3 A64":K$ = "": EXIT SELECT
  236.        END SELECT
  237.        IF Caps THEN K$ = UCASE$(K$)
  238.        IF FPos > LEN(Wkg$) THEN
  239.  
  240.              DO WHILE FPos-LEN(Wkg$) > 1: Wkg$ = Wkg$ + " ": LOOP
  241. '                                                add spaces out to cursor pos.
  242.              Wkg$=Wkg$+K$ '                             ...  and tack on K$
  243.  
  244.      ELSE
  245.              Wkg$ = LEFT$(Wkg$,FPos-1)+K$+MID$(Wkg$,FPos+1+InsertStatus)
  246.      END IF
  247.     '                               the long line plugs K$ in -- the hard way!
  248.      IF K$ <> "" THEN INCR FPos
  249.  
  250.    ELSE  '                            else,  the line is full and Auto is off
  251.  
  252.         PLAY "O0 A64"  '              so we ignore the keystroke & just Beep
  253.  
  254.    END IF
  255.  
  256.  END SELECT
  257.  
  258.  LOOP
  259.  
  260. '                           ***************** END OF MAIN LOOP
  261.  
  262.  LOCATE ,,1,CursorTop,CursorBottom
  263.  EXIT SUB
  264.  
  265. ELeftArrow:
  266.   IF FPos > 1 THEN
  267. '                                      Wkg$ = RTRIM$(Wkg$)
  268.     FPos = FPos - 1
  269.   ELSE
  270.     IF BackOut THEN
  271.        Opt$ = "Left"
  272.        Done = %True
  273.     END IF
  274.   END IF
  275.   RETURN
  276.  
  277. ERightArrow:
  278.   IF FPos < FLength THEN
  279.     INCR FPos
  280.   ELSEIF Auto THEN
  281.     Opt$ = "Auto"
  282.     Done = %True '                                 if Auto is on then exit
  283.   END IF
  284.   RETURN
  285.  
  286. EInsKey:
  287.   IF InsertStatus = %False THEN
  288.     InsertStatus = %True
  289.   ELSE
  290.     InsertStatus = %False
  291.   END IF
  292.   RETURN
  293.  
  294. EDelKey:
  295.   IF FPos = 1 THEN Wkg$ = MID$(Wkg$,2): RETURN
  296.   IF FPos > LEN(Wkg$) THEN
  297.     DECR FPos
  298.   ELSE
  299.     Wkg$ = LEFT$(Wkg$,FPos-1) + MID$(Wkg$,FPos+1)
  300.   END IF
  301.   RETURN
  302.  
  303. EHomeKey:
  304.   FPos = 1
  305.   RETURN
  306.  
  307. EEndKey:
  308.   FPos = LEN(Wkg$)+1
  309.   RETURN
  310.  
  311. ECtrlLeftKey:
  312.  IF FPos > 1 THEN DECR FPos
  313.  DO UNTIL FPos = 1
  314.    DECR FPos
  315.  LOOP UNTIL MID$ (Wkg$,FPos,1) = " "
  316.  IF FPos > 1 THEN INCR FPos
  317.  RETURN
  318.  
  319. ECtrlRightKey:
  320.  DO
  321.    INCR FPos
  322.  LOOP UNTIL MID$ (Wkg$,FPos,1) = " " OR FPos > LEN (Wkg$)
  323.  INCR FPos
  324.  FPos = MIN (FPos, LEN(Wkg$)+1)
  325.  RETURN
  326.  
  327. EUpArrow:
  328.   IF UpOut THEN
  329.     Wkg$ = Starting$
  330.     Opt$ = "Up"
  331.   END IF
  332.   RETURN
  333.  
  334. EDownArrow:
  335.   Opt$ = "Down"
  336.   Done = %True
  337.   RETURN
  338.  
  339.  
  340. EF1Key:
  341.  IF INSTR (Opt$, "F1") THEN
  342.    Opt$ = "HELP!"
  343.    Done = %True
  344.  END IF
  345.  RETURN
  346.  
  347.  
  348. EF2Key:
  349.  IF INSTR (Opt$, "F2") THEN
  350.    Opt$ = "F2"
  351.    Done = %True
  352.  END IF
  353.  RETURN
  354.  
  355.  END SUB                                              REM: ENTERSTRING
  356.  
  357. ' -------------------------------------------------------------------
  358. SUB ENTERNUMBER  (Wkg#, Masq$, Opt$) PUBLIC '          note: Shell for
  359. '                                                                ENTERSTRING
  360. '   =======                This the routine to enter a number onscreen. It
  361. '                          makes the value into a string if <> 0 and calculates
  362. '                          the field length based on Masq$.  Opt$ is simply
  363. '                          passed without much alteration to ENTERSTRING.
  364.  
  365.  LOCAL Wkg$, FLength, DecPlaces
  366.  
  367.  IF VERIFY (Masq$, "#.-$!") THEN
  368.    COLOR %Wht, %Blk
  369.    BEEP: PRINT "ENTERNUMBER: MASK STRING ERROR": EXIT SUB
  370.  END IF
  371.  
  372.  IF INSTR (Masq$, ".") THEN
  373.    DecPlaces = TALLY (MID$ (Masq$, INSTR (Masq$, ".")), "#")
  374.  ELSE
  375.    DecPlaces = 0
  376.  END IF
  377.  Wkg# = ROUNDOFF# (Wkg#, DecPlaces)
  378.  
  379.  Ln = CSRLIN: Col = POS
  380.  FLength = LEN (Masq$)
  381.  Opt$ = "Num" + Opt$
  382.  
  383.  IF Wkg# = 0 THEN
  384.     Wkg$ = ""
  385.  ELSE
  386.     Wkg$ = LTRIM$ (STR$(Wkg#))'     set working $.
  387.  END IF
  388.  
  389.  IF INSTR (Wkg$,".") THEN            '                strip trailing zeroes ...
  390.    Wkg$ = LEFT$(Wkg$,INSTR(Wkg$,".")+4)
  391.    Wkg$ = RTRIM$ (Wkg$, "0")
  392.    Wkg$ = RTRIM$ (Wkg$, ".")
  393.  END IF
  394.  
  395. '                       -----------------------------------
  396.  
  397.                         CALL ENTERSTRING(Wkg$,FLength,Opt$)
  398.  
  399. '                       -----------------------------------
  400.  
  401.  Wkg# = VAL(Wkg$) '                                              reset Wkg# ...
  402.  Wkg# = ROUNDOFF# (Wkg#, DecPlaces)
  403.  LOCATE Ln, Col: PRINT USING Masq$;Wkg# '                            print it
  404. '         ...
  405.  
  406. END SUB                                                         REM ENTERNUMBER
  407.  
  408. ' -------------------------------------------------------------------
  409.  
  410. SUB ENTERDATE  (A$, Opt$) PUBLIC
  411.  
  412.  LOCAL L,C
  413. '                                           set up to use the formatted entry
  414. EnterDate1: '                                routine ENTERBUNCHES with 3 blank
  415.  L = CSRLIN: C = POS '                      fields to fill and 2 hyphens
  416.  DATA 2,"-",2,"-",2,"END"
  417.  RESTORE EnterDate1
  418.  Opt$ = Opt$ + "Num"
  419.  
  420.    CALL ENTERBUNCHES(A$, Opt$)
  421. '                                          now check the result for being a
  422. '                                          valid date (FnFigDate& returns > 0)
  423.  
  424.  IF (Opt$ = "CR" OR Opt$ = "Auto") AND FigDate& (A$) = 0 THEN
  425.     A$ = "": LOCATE L,C: GOTO EnterDate1
  426.  END IF
  427.  
  428. END SUB
  429.  
  430. ' -------------------------------------------------------------------
  431. SUB RotaDate  (D$,Opt$) PUBLIC
  432.  LOCAL L, C, K$, I$()
  433.  DIM I$ (3)
  434.  L = CSRLIN: C = POS
  435.  COLOR BoxColor MOD 16, BoxColor \ 16
  436.  I$(1) = "To enter date shown press [CR]."
  437.  I$(2) = " Use ["+CHR$(27)+"] or ["+CHR$(26)+"] to change."
  438.  I$(3) = "For normal keyboard entry press SpaceBar."
  439.  CALL SCREENPUSH
  440.  CALL BOXMESSAGE2 (18, 24, 0, I$(), 3, 47)
  441.  LOCATE L+1,C+2
  442.  PRINT CHR$(17);CHR$(205);CHR$(205);CHR$(16)
  443.  COLOR FldColor MOD 16, FldColor \ 16
  444.  DO
  445.    LOCATE L,C: PRINT D$;
  446.    DO:LOOP UNTIL INSTAT
  447.    K$ = INKEY$
  448.    IF LEN(K$) < 2 THEN
  449.      PLAY TinyBeep$
  450.      IF K$ = CHR$(13) THEN
  451.         Opt$ = "CR"
  452.         CALL SCREENPOP
  453.         EXIT SUB
  454.      END IF
  455.      IF K$ = CHR$(27) THEN
  456.         Opt$ = "ESC"
  457.         CALL SCREENPOP
  458.         EXIT SUB
  459.      END IF
  460.      IF K$ = " " THEN
  461.         Opt$ = "RegularEntry"
  462.         CALL SCREENPOP
  463.         EXIT SUB
  464.      END IF
  465.    ELSE
  466.      K$ = RIGHT$(K$,1)
  467.  
  468.      SELECT CASE ASC(K$)
  469.        CASE &H4B  '                                    left -- back date 1 day
  470.          D$ = WriteDate$(FigDate&(D$) - 1)
  471.        CASE &H4D  '                                right -- advance date 1 day
  472.          D$ = WriteDate$(FigDate&(D$) + 1)
  473.        CASE &H48 '                                                         up
  474.          Opt$ = "Up": CALL SCREENPOP : EXIT SUB
  475.        CASE &H50  '                                                        down
  476.          Opt$ = "Down": CALL SCREENPOP : EXIT SUB
  477.        CASE &H3C  '
  478.          Opt$ = "F2": CALL SCREENPOP : EXIT SUB
  479.        END SELECT
  480.  
  481.      PLAY TinyBeep$
  482.    END IF
  483.  LOOP
  484.  
  485.  END SUB
  486. ' -------------------------------------------------------------------
  487.  
  488.  
  489. SUB ENTERTIME  (A$, Opt$) PUBLIC
  490.  LOCAL L, C, Hours, H$, AmPm$
  491.  
  492. EnterTime1:
  493.  DATA 2,":",2,"END"
  494.  RESTORE EnterTime1
  495.  Opt$ = Opt$ + "Num"
  496.  L = CSRLIN: C = POS
  497.  
  498.    CALL ENTERBUNCHES(A$, Opt$)
  499.  
  500.  IF A$ <> "" THEN
  501.     IF VAL (LEFT$(A$,2)) > 24 OR VAL (RIGHT$(A$,2)) > 59 THEN
  502.       A$ = ""
  503.       LOCATE L,C
  504.       GOTO EnterTime1
  505.     END IF
  506.  
  507.     IF RIGHT$ (A$,2) = "  " AND LEFT$ (A$,2) <> "  " THEN
  508.       Hours = VAL(LEFT$ (A$,2))
  509.       IF Hours > 10 THEN
  510.          H$ = LEFT$(A$,2)
  511.       ELSE
  512.         H$ = LEFT$ (STR$(Hours),2)
  513.       END IF
  514.       A$ = H$ + ":00"
  515.       LOCATE L,C: PRINT A$
  516.     END IF
  517.  
  518. AMorPM:
  519.     IF LEFT$(A$,2) <> "  " AND VAL (LEFT$(A$,2)) < 13 THEN
  520. '                                             dialog box to select a.m. or p.m.
  521.        CALL SCREENPUSH
  522. '   Code to write Static Window {AM_PM} to Screen
  523. '        note: created by StatWindow Writer (PWW) from AM_PM.PW
  524.  
  525.        COLOR BoxColor MOD 16, BoxColor \ 16
  526.        LOCATE  9, 24
  527.        PRINT "┌──────────────────────────────────────┐"
  528.        LOCATE  10, 24
  529.        PRINT "│    A - for A.M.                      │";
  530.        LOCATE  11, 24
  531.        PRINT "│    P - for P.M.                      │";
  532.        LOCATE  12, 24
  533.        PRINT "│        [ESC] to Quit                 │";
  534.        LOCATE  13, 24
  535.        PRINT "│              Time entered:           │";
  536.        LOCATE  14, 24
  537.        PRINT "└──────────────────────────────────────┘";
  538.  
  539.        COLOR FldColor MOD 16, FldColor \ 16
  540.        LOCATE  13, 53
  541.        PRINT USING  "\   \";A$;
  542.        COLOR ScrColor MOD 16, ScrColor \ 16
  543.  
  544. '  08-22-1990, 18:40:   end of StatWindow generated code for window {AM_PM}
  545.        DO
  546.          AmPm$ = UCASE$ (INKEY$)
  547.        LOOP UNTIL AmPm$ = "A" OR AmPm$ = "P"
  548.        CALL SCREENPOP
  549.        A$ = A$ + " " + MID$ ("a.m.p.m.", 5 + 4*(AmPm$="A"), 4)
  550.        LOCATE L,C: PRINT A$
  551.      END IF
  552.  END IF
  553.  END SUB
  554.  
  555. ' -------------------------------------------------------------------
  556.  
  557. SUB ENTERSSN  (A$, Opt$) PUBLIC
  558.  
  559. EnterSSN1:
  560.  DATA 3," ",2," ",4,"END"
  561.  RESTORE EnterSSN1
  562.  Opt$ = Opt$ + "Num"
  563.  
  564.    CALL ENTERBUNCHES(A$, Opt$)
  565.  
  566. END SUB
  567.  
  568. ' -------------------------------------------------------------------
  569.  
  570.  
  571. SUB ENTERPHONE  (A$, Opt$) PUBLIC
  572.  
  573.  LOCAL L,C
  574.  
  575. EnterPhone1:
  576.  DATA "(",3,") ",3,"-",4," ext. ",5
  577.  DATA END
  578. EShortPhone:
  579.  DATA "(",3,") ",3,"-",4
  580.  DATA END
  581.  LOCAL WithExtension
  582.  
  583.  IF INSTR(Opt$,"NoExt") THEN
  584.      RESTORE EShortPhone
  585.    ELSE
  586.      RESTORE EnterPhone1
  587.      WithExtension = %True
  588.    END IF
  589.  A$ = LTRIM$ (RTRIM$ (A$))
  590.  IF A$ = "" THEN A$ = "("+LocalAreaCode$+")"
  591.  Opt$ = Opt$ + "Num"
  592.  
  593.    CALL ENTERBUNCHES(A$, Opt$)
  594.  
  595.  A$ = LTRIM$ (RTRIM$ (A$))
  596.  IF WithExtension THEN
  597.    IF RIGHT$ (A$,4) = "ext." THEN A$ = LEFT$ (A$,19)  ' if no ext # then trim
  598.    PRINT USING "\"+SPACE$(23)+"\"; A$  '                 off the word "ext."
  599.  ELSE
  600.    PRINT USING "\"+SPACE$(14)+"\"; A$
  601.  END IF
  602.  END SUB  '
  603.  
  604. ' -------------------------------------------------------------------
  605.  
  606. SUB ENTERBUNCHES (A$, Opt$)
  607.  LOCAL L, C, FLength, Sep$(), Size(), Bunch%, B$, B%, FPos, Opt0$
  608.  DIM Sep$ (20): DIM Size (20)
  609.  Bunch% = 1
  610.  L = CSRLIN: C = POS
  611.  READ B$
  612.  DO UNTIL B$ = "END"
  613.    IF INSTR("123456789",B$) THEN
  614.       Size(Bunch%) = VAL (B$)
  615.       INCR FLength, (LEN(Sep$(Bunch%))+Size(Bunch%))
  616.       INCR Bunch%                   ' get sizes of bunches and separator chrs
  617.    ELSE
  618.       Sep$(Bunch%) = B$
  619.    END IF
  620.    READ B$
  621.  LOOP
  622.  
  623.  A$ = A$ + SPACE$(FLength-LEN(A$))
  624.  
  625.  
  626.  B% = 1
  627.  FPos = 1                              '  this is to move the cursor past a
  628.  IF Opt$ <> "Up" THEN
  629.    DO UNTIL FPos > LEN(A$) '            full field:  check first chr of each
  630.      IF MID$(A$,LEN(Sep$(B%))+FPos,1) <> " " THEN  '  bunch for being blank ...
  631.        INCR FPos,  LEN(Sep$(B%)) + Size(B%)
  632.        INCR B%                                  ' if it isn't, jump over it ...
  633.      ELSE
  634.        EXIT LOOP
  635.      END IF
  636.   LOOP
  637.   IF Fpos >= FLength THEN B% = 1: FPos = 1  '            for a full field,
  638.  END IF  '                                     set cursor back to pos. # 1 ...
  639.  
  640. '   now the bunch to start with is B% // the starting $ is A$
  641.  
  642.  
  643. TakeEntry:
  644.  LOCATE L,C: PRINT USING "\"+SPACE$(FLength-2)+"\"; A$
  645.  
  646.  Opt0$ = Opt$
  647.  DO UNTIL Size(B%) = 0
  648.    LOCATE L, (C + FPos-1)
  649.    PRINT Sep$(B%);
  650.    Ln = CSRLIN: Col = POS
  651.    Opt$ = Opt0$+"Auto BackOut UpOut"
  652.    B$ = MID$ (A$, FPos+LEN(Sep$(B%)), Size(B%))
  653.  
  654.      CALL ENTERSTRING (B$,Size(B%),Opt$)
  655.  
  656.    MID$(A$,FPos) = Sep$(B%)+B$
  657.  
  658.  SELECT CASE Opt$
  659.  
  660.    CASE "Left"
  661.      IF B% > 1 THEN
  662.        DECR B%
  663.        DECR FPos, Size(B%)+LEN(Sep$(B%))
  664.           END IF
  665.  
  666.    CASE "Up", "ESC", "F2", "HELP!", "Tab", "ShfTab", "CR", "Down"
  667.      EXIT LOOP
  668.  
  669.    CASE "Auto"
  670.      INCR FPos, Size(B%)+LEN(Sep$(B%))
  671.      INCR B%
  672.  
  673.    CASE ELSE
  674.      PRINT "ENTERBUNCHES: Error! Opt$ = "; Opt$; :CALL CloseFiles: STOP
  675.  
  676.  END SELECT
  677.  LOOP
  678.  
  679. BunchDone:
  680.  LOCATE L,C
  681. END SUB  '                                          REM    ENTERBUNCHES
  682.  
  683. SUB PressAKey PUBLIC
  684.  LOCAL Click
  685.  
  686.  LOCATE 20, 58, 0: COLOR 0,7
  687.  PRINT "╔═════════════════╗"                ' pcWrite is great for boxing now!
  688.  LOCATE 21, 58
  689.  PRINT "║   HIT ANY KEY   ║"           ' (always did do a zippy search/replace)
  690.  IF NeedDCon THEN
  691.    LOCATE 22, 58
  692.    PRINT "║ OR CLICK RODENT ║"
  693.    LOCATE 23, 58
  694.    PRINT "║    TO GO ON     ║"
  695.    LOCATE 24, 58
  696.    PRINT "╚═════════════════╝";
  697.  ELSE
  698.    LOCATE 22, 58
  699.    PRINT "║    TO GO ON     ║"
  700.    LOCATE 23, 58
  701.    PRINT "╚═════════════════╝";
  702.  END IF
  703.  
  704.  PLAY PressAKeyBeep$
  705.  IF NeedDCon THEN
  706.    DO
  707.      CALL Mouse (%ReadRodent, Click, X, Y)
  708.    LOOP UNTIL ((INKEY$ <> "") OR Click)
  709.  ELSE
  710.    DO: LOOP UNTIL INKEY$ <> ""
  711.  END IF
  712.  
  713.  LOCATE ,,1
  714.  
  715.  END SUB
  716. '____________________________________________________________________________
  717.  
  718. FUNCTION GetYesOrNo PUBLIC
  719.    LOCAL X$
  720.    PRINT " (y/n) ";
  721.    DO WHILE X$ <> "Y" AND X$ <> "N"
  722.      IF NeedDCon THEN
  723.        DO
  724.          CALL Mouse (%ReadRodent, Click, X, Y)
  725.        LOOP UNTIL (INSTAT OR Click)
  726.      ELSE
  727.        Click = %False
  728.        DO: LOOP UNTIL INSTAT
  729.      END IF
  730.      X$ = INKEY$
  731.      X$ = UCASE$(X$)
  732.      IF Click = %LeftButton THEN X$ = "Y"
  733.      IF Click = %RightButton THEN X$ = "N"
  734.    LOOP
  735.    PRINT X$;
  736.    GetYesOrNo = (X$ = "Y")
  737.    END FUNCTION
  738.  
  739. SUB ENTERYESNO  (Yes) PUBLIC
  740.  LOCAL Choice$, L, C
  741.  COLOR FldColor MOD 16, FldColor \ 16
  742.  L = CSRLIN
  743.  C = POS
  744.  PRINT "Y"
  745.  LOCATE L, C
  746.  DO
  747.    DO:LOOP UNTIL INSTAT
  748.    Choice$ = INKEY$
  749.    SELECT CASE Choice$
  750.      CASE "y", "Y", CHR$(13)
  751.        PRINT "Y"
  752.        Yes = %True
  753.        EXIT LOOP
  754.      CASE "n", "N", CHR$(27)
  755.        PRINT "N"
  756.        Yes = %False
  757.        EXIT LOOP
  758.      CASE ELSE
  759.        PLAY OopsBeep$
  760.    END SELECT
  761.  LOOP
  762.  END SUB '                                         REM -- ENTERYESNO
  763.  
  764. FUNCTION ROUNDOFF# (N#, Places%)
  765.  SELECT CASE Places%
  766.    CASE 0
  767.      ROUNDOFF# = ROUND (N#, 0)
  768.      EXIT SELECT
  769.    CASE 1
  770.      ROUNDOFF# = ROUND (N#, 1)
  771.      EXIT SELECT
  772.    CASE 2
  773.      ROUNDOFF# = ROUND (N#, 2)
  774.      EXIT SELECT
  775.    CASE 3
  776.      ROUNDOFF# = ROUND (N#, 3)
  777.      EXIT SELECT
  778.    CASE 4
  779.      ROUNDOFF# = ROUND (N#, 4)
  780.  END SELECT
  781. END FUNCTION
  782.