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