home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / ddut / datainp.sub < prev    next >
Text File  |  1985-07-19  |  9KB  |  118 lines
  1. 50000 '************************************************************************
  2. 50010 'DATAINP.SUB -- WRITTEN BY DAVE GRIMMER ON 7-17-85
  3. 50020 '************************************************************************
  4. 50030 'THIS SUBROUTINE EDITS DATA BEING ENTERED FROM THE KEYBOARD 1 CHARACTER
  5. 50040 'AT A TIME.  DATA INPUT CAN BE RESTRICTED TO BEING INVISIBLE, NUMERIC,
  6. 50050 'A MINIMUM NUMBER OF DIGITS, DATES, NUMERIC RANGES, OR UPPER CASE ONLY.
  7. 50060 'AN EXAMPLE PROGRAM FOLLOWS:
  8. 50070 '---------------------------------------------------------------------
  9. 50080 '10 GOSUB 51360: GOSUB 51380 'DEFINE VARIABLES ONCE
  10. 50090 '20 LOCATE 10,12:PRINT "ENTER A DATE:"
  11. 50100 '30 XROW=10:XCOL=40:XDATE=1:XFMT=1:XCONF=0:GOSUB 51000:ANS$=XOUT$
  12. 50110 '40 PRINT "YOU ENTERED ";ANS$
  13. 50120 '50 LOCATE 16,30:PRINT "MORE (Y/N)?";
  14. 50130 '60 XROW=16:XCOL=42:XYORN=1:XCONF=1:GOSUB 51000
  15. 50140 '70 IF XOUT$="Y" THEN CLS: GOTO 10 ELSE END
  16. 50150 '---------------------------------------------------------------------
  17. 50160 'IN THE EXAMPLE ABOVE, LINE 30 BRINGS A VALID MM/DD/YY DATE.
  18. 50170 'LINE 60 BRINGS IN 1 CHARACTER, EITHER A Y OR N CONVERTED TO UPPER-CASE.
  19. 50180 '************************************************************************
  20. 50190 'THE VARIABLE XFLAG CONTAINS AN ERROR CODE:
  21. 50200 '1  BAD XROW #             2  BAD XCOL #
  22. 50210 '3  BAD XLEN               4  XNUM NOT 0 OR 1
  23. 50220 '5  XDATE NOT 0 OR 1       6  XPRIV NOT 0 OR 1
  24. 50230 '7  XCONV NOT 0 OR 1       8  BAD XMUST
  25. 50240 '9  XRANGE NOT 0 OR 1      10 XFMT NOT 0 OR 1
  26. 50250 '11 XCUR NOT 0 OR 1        12 0<=XSTART<=7
  27. 50260 '13 0<=XSTOP<=7            14 1<=XCHAR<=254
  28. 50270 '15 37<=XFREQ<=32767       16 .0015<=XDUR<=65535
  29. 50280 '17 XCOL+XLEN>79           18 XMUST>XLEN
  30. 50290 '19 XYORN NOT 0 OR 1       20 XCONF NOT 0 OR 1
  31. 50300 '************************************************************************
  32. 50310 'EXECUTE THE NEXT 2 STATEMENTS AT THE START OF YOUR PROGRAM.
  33. 50320 'GOSUB 51360 'SET DEFAULT PARAMETERS FOR DATAINP.SUB
  34. 50330 'GOSUB 51380 'CREATE NON-DEFAULT VARIABLES FOR DATAINP.SUB
  35. 50340 '************************************************************************
  36. 50350 'XROW--------->INPUT ROW (MUST BE GIVEN)
  37. 50360 'XCOL--------->INPUT COL (MUST BE GIVEN)
  38. 50370 'XLEN--------->LENGTH OF INPUT FIELD (MUST BE GIVEN FOR ALL BUT DATE)
  39. 50380 'XNUM--------->0 IS ALPHANUMERIC, 1 IS NUMERIC ONLY
  40. 50390 '    --------->DEFAULT IS 0
  41. 50400 'XDATE-------->0 IS NON-DATE, 1 IS DATE FORMAT
  42. 50410 '     -------->DEFAULT IS 0 (1 SETS XLEN, XNUM, XMUST, AND XRANGE)
  43. 50420 'XPRIV-------->0 IS NON-PRIVATE, 1 IS PRIVATE
  44. 50430 '     -------->DEFAULT IS 0
  45. 50440 'XCONV-------->0 IS LOWER AND UPPER, 1 IS CONVERT ALL TO UPPER
  46. 50450 '     -------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  47. 50460 'XCONF-------->0 IS NO ENTER KEY REQUIRED, 1 IS ENTER REQUIRED TO CONFIRM
  48. 50470 '     -------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  49. 50480 'XMUST-------->NUMBER OF CHARACTERS THAT MUST BE ENTERED
  50. 50490 '     -------->DEFAULT IS 0
  51. 50500 'XYORN-------->0 IS NOT "Y" OR "N", 1 IS "Y" OR "N" ONLY
  52. 50510 '     -------->DEFAULT IS 0 (1 SETS XLEN, XMUST, AND XCONV)
  53. 50520 'XRANGE------->0 IS NO RANGE CHECKED, 1 IS CHECK XMIN AND XMAX
  54. 50530 '      ------->DEFAULT IS 0
  55. 50540 'XMIN--------->MINIMUM ACCEPTABLE VALUE WHEN XRANGE=1
  56. 50550 '    --------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  57. 50560 'XMAX--------->MAXIMUM ACCEPTABLE VALUE WHEN XRANGE=1
  58. 50570 '    --------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  59. 50580 'XFMT--------->0 IS NO FORMAT FOR DATES, 1 IS MM/DD/YY
  60. 50590 '    --------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  61. 50600 'XCUR--------->0 IS NO CURSOR, 1 IS CURSOR VISIBLE
  62. 50610 '    --------->DEFAULT IS 1
  63. 50620 'XSTART------->REFERS TO CURSOR (XCUR) SIZE -- RANGE 0-7
  64. 50630 '      ------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  65. 50640 'XSTOP-------->REFERS TO CURSOR (XCUR) SIZE -- RANGE 0-7
  66. 50650 '     -------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  67. 50660 'XCHAR-------->ASCII VALUE OF THE FILL CHARACTER
  68. 50670 '     -------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  69. 50680 'XFREQ-------->FREQUNCY USED IN SOUND STATEMENTS
  70. 50690 '     -------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  71. 50700 'XDUR--------->DURATION USED IN SOUND STATEMENTS
  72. 50710 '    --------->NO DEFAULT -- VALUE FROM PREVIOUS CALL IS USED
  73. 50720 'XOUT$-------->CONTAINS THE INPUT FIELD UPON RETURNING
  74. 50730 'XFLAG-------->CONTAINS ERROR CODE GENERATED
  75. 50740 '************************************************************************
  76. 51000 XOUT$ = "": IF XDATE THEN XLEN=8:XNUM=1:XMUST=8:XRANGE=0 ELSE IF XYORN THEN XLEN=1:XMUST=1:XCONV=1
  77. 51010 'IF THIS RUNS TO SLOWLY, THE NEXT 6 LINES MAY BE DELETED.
  78. 51020 XFLAG=0:IF XROW<1 OR XROW>25 THEN XFLAG=1 ELSE IF XCOL<1 OR XCOL>79 THEN XFLAG=2 ELSE IF XLEN<1 OR XLEN>79 THEN XFLAG=3 ELSE IF XNUM<>0 AND XNUM<>1 THEN XFLAG=4
  79. 51030 IF XDATE<>0 AND XDATE<>1 THEN XFLAG=5 ELSE IF XPRIV<>0 AND XPRIV<>1 THEN XFLAG=6 ELSE IF XCONV<>0 AND XCONV<>1 THEN XFLAG=7 ELSE IF XMUST<0 OR XMUST>79 THEN XFLAG=8
  80. 51040 IF XRANGE<>0 AND XRANGE<>1 THEN XFLAG=9 ELSE IF XFMT<>0 AND XFMT<>1 THEN XFLAG=10 ELSE IF XCUR<>0 AND XCUR<>1 THEN XFLAG=11 ELSE IF XSTART<0 OR XSTART>7 THEN XFLAG=12 ELSE IF XSTOP<0 OR XSTOP>7 THEN XFLAG=13
  81. 51050 IF XCHAR<1 OR XCHAR>254 THEN XFLAG=14 ELSE IF XFREQ<37 OR XFREQ>32767 THEN XFLAG=15 ELSE IF XDUR<.0015 OR XDUR>65535! THEN XFLAG=16
  82. 51060 IF XCOL+XLEN>79 THEN XFLAG=17 ELSE IF XMUST>XLEN THEN XFLAG=18 ELSE IF XYORN<>0 AND XYORN<>1 THEN XFLAG=19 ELSE IF XCONF <>0 AND XCONF<>1 THEN XFLAG=20
  83. 51070 IF XFLAG<>0 THEN PRINT "ERROR ENCOUNTERD IN SUBROUTINE: XFLAG =";XFLAG:END
  84. 51080 LOCATE XROW,XCOL,XCUR,XSTART,XSTOP: IF XPRIV THEN PRINT STRING$(XLEN,XCHAR); : ELSE PRINT XOUT$ + STRING$(XLEN-LEN(XOUT$),XCHAR);
  85. 51090 IF XCONF=0 THEN IF LEN(XOUT$)=XLEN THEN 51210
  86. 51100 LOCATE XROW,XCOL+LEN(XOUT$),XCUR,XSTART,XSTOP
  87. 51110 A$ = INKEY$ : IF A$ = "" THEN 51110 ELSE A=ASC(A$) 'GET 1 CHAR
  88. 51120 IF A=8 AND LEN(XOUT$)=0 THEN GOSUB 51340: GOSUB 51390: GOTO 51080
  89. 51130 IF (A=8 AND XDATE<>1) OR (A=8 AND XDATE=1 AND (LEN(XOUT$)=1 OR LEN(XOUT$)=4 OR LEN(XOUT$)=7 OR LEN(XOUT$)=8)) OR A<>8 THEN 51140 ELSE XOUT$=LEFT$(XOUT$,LEN(XOUT$)-2):GOTO 51080 'BACKSPACES
  90. 51140 IF A=8 THEN IF LEN(XOUT$)=0 THEN GOSUB 51340: GOSUB 51390: GOTO 51080 ELSE GOTO 51410
  91. 51150 IF A<>13 AND LEN(XOUT$) = XLEN THEN GOSUB 51340:PRINT "TO MANY CHARACTERS...";:GOTO 51080
  92. 51160 IF A=13 THEN IF XMUST<=LEN(XOUT$) THEN 51210 ELSE GOSUB 51340:PRINT "NOT ENOUGH CHARACTERS...";:GOTO 51080
  93. 51170 IF XDATE AND (A=46 OR A=45) THEN GOSUB 51340: GOSUB 51390: GOTO 51080
  94. 51180 IF XNUM THEN IF A>44 AND A<58 AND A<>47 THEN XOUT$=XOUT$+A$:IF XDATE THEN IF LEN(XOUT$)=2 OR LEN(XOUT$)=5 THEN XOUT$=XOUT$+"/":GOTO 51080:ELSE GOTO 51080:ELSE GOTO 51080:ELSE GOSUB 51340:GOSUB 51390:GOTO 51080
  95. 51190 IF XCONV AND A>96 AND A<123 THEN A=ASC(A$)-32 : A$=CHR$(A)
  96. 51200 IF A>31 AND A<127 THEN XOUT$=XOUT$ + A$ : GOTO 51080 ELSE GOSUB 51340: GOSUB 51390: GOTO 51080
  97. 51210 'CHECK FINAL ANSWER
  98. 51220 IF XYORN THEN IF XOUT$="Y" OR XOUT$="N" THEN 51350 ELSE GOSUB 51340:PRINT "MUST RESPOND EITHER Y OR N";:GOTO 51410
  99. 51230 IF XDATE<>1 THEN IF XNUM AND LEFT$(XOUT$,1)="-" THEN IF XOUT$=STR$(VAL(XOUT$)) THEN 51250 ELSE GOSUB 51340:PRINT "NOT NUMERIC....";:GOTO 51410
  100. 51240 IF XDATE<>1 THEN IF XNUM THEN IF LEN(STR$(VAL(XOUT$)))-1 < LEN(XOUT$) THEN GOSUB 51340:PRINT "NOT NUMERIC...";:GOTO 51410
  101. 51250 IF XNUM AND XRANGE THEN IF VAL(XOUT$)>=XMIN AND VAL(XOUT$)<=XMAX THEN 51350 ELSE GOSUB 51340:PRINT "MIN =";XMIN;"    MAX =";XMAX;:GOTO 51410
  102. 51260 IF XDATE AND XFMT THEN 51270 ELSE 51350
  103. 51270 TMP1=VAL(LEFT$(XOUT$,2)): IF TMP1>12 OR TMP1<1 THEN 51330
  104. 51280 TMP2=VAL(MID$(XOUT$,4,2)): IF TMP2<1 OR TMP2>31 THEN 51330
  105. 51290 IF (TMP1=4 OR TMP1=6 OR TMP1=9 OR TMP1=11) AND TMP2>30 THEN 51330
  106. 51300 TMP3=VAL(RIGHT$(XOUT$,2))
  107. 51310 IF TMP1=2 AND TMP2>29 AND TMP3 MOD 4 = 0 THEN 51330
  108. 51320 IF TMP1=2 AND TMP2>28 AND TMP3 MOD 4 > 0 THEN 51330 ELSE 51350
  109. 51330 GOSUB 51340: PRINT "FORMAT IS MM/DD/YY";:GOTO 51410
  110. 51340 LOCATE 25,1:PRINT SPACE$(79);:LOCATE 25,1:SOUND XFREQ,XDUR:RETURN
  111. 51350 'SET ALL DEFAULT SETTINGS AND RETURN
  112. 51360 XNUM=0:XDATE=0:XPRIV=0:XCUR=1:XMUST=0:XYORN=0:XRANGE=0:LOCATE 25,1,,7,7:PRINT SPACE$(79);:LOCATE 1,1:RETURN
  113. 51370 'INITIAL SETTINGS FOR NON-DEFAULT VARIABLES IN THE DATAINP SUBROUTINE
  114. 51380 XCONV=0:XFMT=0:XCONF=0:XMIN=0:XMAX=0:XROW=0:XCOL=0:XLEN=0:XSTART=0:XSTOP=7:XCHAR=249:XFREQ=5000:XDUR=.125:RETURN
  115. 51390 PRINT "BAD KEY...";:RETURN 'BAD KEY ROUTINE
  116. 51400 'BACKSPACE 1 CHARACTER, AND RESTART LOOPING
  117. 51410 XOUT$=LEFT$(XOUT$,LEN(XOUT$)-1):GOTO 51080
  118.