home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / BASIC / QBINPUT.ZIP / QBINPUT.BAS
Encoding:
BASIC Source File  |  1987-06-03  |  7.4 KB  |  262 lines
  1.  
  2. ' Amazingly enough, here is another modification of the input.arc file
  3. ' and the input2.arc files found on Genie.
  4.  
  5. ' I wrote the original INPUT.ARC and it has since been greatly enhanced by
  6. ' Mr. Grainger.  I downloaded his version and made a few more changes
  7. ' to it (and the way some things work).
  8.  
  9. ' It is called with:
  10.  
  11. ' sub getin(tp$,ulc%,numonly%,mxl%,x1%,y1%,ntp$,ab$) static
  12.  
  13. '   tp$ - Default string to display (may be left blank)
  14. '   ulc% - 1 to force uppercase  - 0 to leave as typed
  15. '   numonly% - 1 to force numbers only - 0 for alphanumeric
  16. '   mxl% - max. # of characters for input  ( <75 )
  17. '   x1% - row to start (if a 0 is put here, the position is of the last print)
  18. '   y1% - column to start (if a 0 is put here, the position is of the last print)
  19. '     TO USE A '0' ABOVE : Locate x,y:print "Input : ";:call getin ....
  20.  
  21. '   ntp$ - code retured
  22. '   ab$ - string returned (edited string returned to calling program)
  23. '
  24. '   Uses FASTPRT by Dave Evers to print status line (change to print if you don't have it)
  25. '       (Daves' programs are GREAT, well worth buying)
  26. '
  27. '     Files QBINPUT.ARC (this file) and Input.ARC uploaded by:
  28.  
  29. '               Jeff Goza
  30. '               PO Box 6401
  31. '               Abilene, Tx 79608-6401
  32. '               915-692-9461
  33. '                 Genie Mail : J.GOZA
  34. '                 CSERVE     : 75056,3555
  35.  
  36. '     File Input2.ARC uploaded by:
  37. '
  38. '               Garrett Grainger, Jr.
  39. '               8145 Swaps Way
  40. '               Lake Park, Florida 33418-6034
  41. '               305-627-8348
  42. '
  43. '               Mail to: G.Grainger
  44.  
  45. ' example call getin("Sample Txt",0,0,16,5,10,ntp$,ab$)
  46. '         produces "Sample Txt" on row 5,column 10
  47. '         with the cursor under the S in Sample - will accept 16 characters
  48. '         and allow alphanumeric input.  The string will return in upper/lower case
  49. '         If ESC is pressed, the entry is cleared, and
  50. '         you may reenter the information
  51.  
  52. '         The INS key toggles OW (overwrite) and INS (Insert) modes
  53. '          OW types over current entries, INS inserts characters
  54.  
  55. ' **********************
  56. '    There must be other QuickBasic programmers out there (you downloaded this.)
  57. '    I would like to hear from you.  Ideas? Complaints? Questions? let me know.
  58. ' **********************
  59.  
  60. sub getin(tp$,numonly%,ulc%,mxl%,x1%,y1%,ntp$,ab$) static
  61.  
  62.        if x1%=0 then x1%=csrlin         ' set for current location
  63.        if y1%=0 then y1%=pos(0)
  64.  
  65.        zl$=tp$
  66.     IF LEFT$(TP$,2)="  " THEN ZL$=""
  67.     eflag1%=1                       'insert mode on
  68.     nc=mxl%                         'max # chars
  69.     char$=chr$(95):ul=ulc%          ' char$ = "_" - change as you wish
  70.     numonly=numonly%
  71.     IF zl$="" THEN
  72.         locate x1%,y1%:print STRING$(NC,char$)
  73.         eflag1%=0     '******** edit - overwrite switch INS on now
  74.     end if
  75.  
  76.     locate x1%,y1%:print zl$:diff=mxl%-len(zl$)
  77.     locate x1%,y1%+len(zl$):print string$(diff,char$)
  78.  
  79.     CURRENT=1:bx=x1%:by=y1%
  80.     ab$=""
  81.     a=0
  82.     if zl$="" or zl$=" " then goto stall
  83.     if len(zl$)<>nc then goto stall
  84.  
  85. stall:
  86.     ab$=INKEY$
  87.  
  88.     IF ab$<>"" THEN A=ASC(RIGHT$(ab$,1))
  89.     call capscheck(eflag%,nim$,cap$,ike$)
  90.     if len(ab$)=2 then
  91.      if right$(ab$,1)="Q" then NTP$="Q":goto done2:
  92.  
  93. '************ processes PgUP and PgDn keys and returns an I or Q
  94. '             check if len(ab$)=2 and ntps$="I" for processing.
  95. '               exits input routine
  96.  
  97.     if right$(ab$,1)="I" then ntp$="I":goto done2
  98.     if right$(ab$,1)="R" and eflag%=1 then eflag%=0:goto stall
  99.     if right$(ab$,1)="R" and eflag%=0 then eflag%=1:goto stall
  100.     end if
  101.  
  102.     if eflag1%=1 and eflag%=1 and ab$<>"" and ab$<>chr$(13) then
  103.         eflag1%=0
  104.     end if
  105.  
  106. ' ************** Toggle for the insert Key
  107.  
  108.     if eflag%=0 and ab$<>"" then eflag1%=1
  109.  
  110.     if ab$=chr$(27) then                            ' clears entry
  111.         zl$="":current=1
  112.         locate bx,by:print string$(mxl%,95);
  113.         goto stall
  114.     end if
  115.  
  116.  
  117.     select case ab$
  118.     case "G" to "K","M","O" to "S"
  119.         a=0
  120.     case ""
  121.         goto update
  122.     case else
  123.         a=a
  124.     end select
  125.  
  126.     select case a
  127.     case 72,73,80 to 82
  128.         goto update:
  129.     case 13
  130.         locate x1%,y1%+current-1:print " ":GOTO done
  131.     case 79
  132.         locate x1%,y1%+current-1:print MID$(zl$,CURRENT,1)
  133.         CURRENT=LEN(zl$)+1
  134.         GOTO update:
  135.     case 83
  136.         if current>len(zl$) then goto update:
  137.         if current<=len(zl$) then
  138.             zl$=left$(zl$,current-1)+right$(zl$,len(zl$)-current)
  139.             PAD=NC-LEN(zl$)
  140.             PAD$=STRING$(PAD,char$)
  141.             locate x1%,y1%:print zl$+pad$
  142.             CURRENT=CURRENT
  143.             GOTO update:
  144.         end if
  145.  
  146.     case 71
  147.         locate x1%,y1%+len(zl$):print char$;
  148.         locate x1%,y1%+current-1:print MID$(zl$,CURRENT,1);
  149.         CURRENT=1
  150.         GOTO update:
  151.  
  152.     case 75
  153.         if CURRENT=<1 THEN GOTO UPDATE:
  154.         if current>len(zl$) then_
  155.         locate x1%,y1%+len(zl$):print char$;
  156.         if CURRENT>1 THEN CURRENT=CURRENT-1:GOTO update:
  157.     case 77
  158.         if CURRENT>LEN(zl$) THEN goto update
  159.         if CURRENT<NC THEN CURRENT=CURRENT+1:GOTO update:
  160.     case 8
  161.         if current=1 then goto update:
  162.         if CURRENT>1 THEN
  163.             zl$=LEFT$(zl$,CURRENT-2)+RIGHT$(zl$,LEN(zl$)-CURRENT+1)
  164.             PAD=NC-LEN(zl$)
  165.             PAD$=STRING$(PAD,char$)
  166.             locate x1%,y1%:print zl$+pad$;
  167.             CURRENT=CURRENT-1
  168.             GOTO update:
  169.         end if
  170.     case else
  171.         a=a
  172.     end select
  173.  
  174.     locate x1%,y1%+current-1:print MID$(zl$,CURRENT,1);
  175.  
  176.     IF LEN(ZL$)>=NC AND EFLAG%=0 THEN
  177.         call snd
  178.         GOTO update
  179.     end if
  180.  
  181.     IF CURRENT>NC THEN
  182.          CALL SND
  183.          GOTO UPDATE
  184.     END IF
  185.  
  186.     IF NUMONLY=1 AND ab$="." THEN goto t185
  187.     IF NUMONLY=1 AND ab$<"0" OR NUMONLY=1 AND ab$>"9" THEN
  188.         call snd
  189.         GOTO update
  190.     end if
  191. t185:
  192.     t1=len(zl$)+1
  193.     if current=t1 then eflag%=0        'turn on insert mode, end of line
  194.     if eflag%=0 then zl$=LEFT$(zl$,CURRENT-1)+ab$+RIGHT$(zl$,LEN(zl$)-CURRENT+1)
  195.     if eflag%=1 then mid$(zl$,current,1)=ab$
  196.      locate x1%,y1%:print zl$;
  197.     CURRENT=CURRENT+1
  198.  
  199. Update:
  200.     locate x1%,CURRENT+y1%-1,1,4,7
  201.     A=0
  202.     GOTO stall:
  203. Done:
  204.     templ=nc-len(zl$)
  205.     locate x1%,y1%+len(zl$):print string$(templ+1," ");
  206.     locate x1%,y1%:print zl$;
  207.     numonly=0
  208.     if ulc%=1 then call upperlower(zl$,re$):zl$=re$
  209.     call strip(zl$,ntp$)
  210. Done2:
  211.     locate bx,by:print zl$;:ab$=zl$
  212.     end sub
  213.  
  214. '************ Capscheck queries the keyboard for the status of the caps,num,shift
  215. '             and INS keys.
  216.  
  217. sub capscheck(eflag%,nim$,cap$,ike$) static
  218. 'returns spaces if not on, letters if on
  219.  
  220.         DEF SEG=0
  221.         v$=date$
  222.         CAP$="    "
  223.         nim$="   "
  224.         if eflag%=1 then ike$=" OW"
  225.         if eflag%=0 then ike$="INS"
  226.         IF PEEK(&H417) AND 64 THEN CAP$="CAPS"
  227.         IF PEEK(&H418) AND 64 THEN CAP$="    "
  228.         IF PEEK(&H417) AND 32 THEN NIM$="NUM"
  229.         IF PEEK(&H418) AND 32 THEN NIM$="   "
  230.         IF (PEEK(&H417) AND 2) OR (PEEK(&H417) AND 1) THEN CAP$="CAPS"
  231.         IF (PEEK(&H418) AND 2) OR (PEEK(&H418) AND 1) THEN CAP$="    "
  232.         call fastprt("  "+IKE$+" "+NIM$+" "+CAP$,25,1,7)
  233. end sub
  234.  
  235. ' *** Upper/Lower case conversion - 1 for uppercase 0 for as entered ***
  236.  
  237. sub upperlower(in$,out$) static
  238.  
  239.   out$=in$
  240.   for y=1 to len(in$)
  241.     ch$=mid$(in$,y,1)
  242.     ac=asc(ch$):if ac>96 and ac<123 then new$=chr$(ac-32):mid$(out$,y,1)=new$
  243.   next y
  244.  end sub
  245.  
  246. '************** strips trailing blanks from entries.
  247. ' used as call strip(sending string to strip,returned stripped string)
  248.  
  249. sub strip(rax$,clean$) static
  250.     FOR SS=1 TO len(rax$)
  251.         IF MID$(rax$,SS,2)="  " THEN Rax$=LEFT$(Rax$,SS-1):exit for
  252.     NEXT SS
  253.     clean$=rax$
  254. end sub
  255.  
  256. '************** Used instead of beep for error notification.
  257. 'used as "call snd"
  258.  
  259. sub snd static
  260.  SOUND 1000,1:SOUND 1500,2:SOUND 500,1
  261. end sub
  262.