home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / BASIC / MASK.ZIP / MASK.BAS < prev    next >
Encoding:
BASIC Source File  |  1987-12-30  |  16.3 KB  |  417 lines
  1. '                              MASKINPUT
  2. '                       (C) 1987 By Kevin L. Curtis
  3. '                              12/30/87
  4. '
  5. '     Routine Name:  MASKINPUT
  6. '          Version:  1.0
  7. '       Written by:  Kevin L. Curtis
  8. '         Language:  QuickBASIC 3.0
  9. '
  10. '          Purpose:  A highly versatile user input routine that uses
  11. '                    a mask$ value passed much like the picture function
  12. '                    in some popular Data Base products.
  13. '
  14. '          Example:  mask$ = "(   )   -    "   for phone number or
  15. '                    mask$ = space$(40)        for blank field.
  16. '
  17. 'Parameters passed:  row%,col%,attr%,mask$,DefaultVal$,ReturnVal$,
  18. '                     ftype% = 0
  19. '            Where:  row% = Row for field input.
  20. '                    col% = Column for field input.
  21. '                    attr% = Use ADVBAS CALL CALCATTR(foreground%,_
  22. '                            background%,attr%) to get attr% value or
  23. '                            (BACKGROUND * 16) + FOREGROUND = attr%.
  24. '                    mask$ = What ever you want your field to look like.
  25. '                            "   -  -   " or "  /  /  "
  26. '                    DefaultVal$ = the default value for the field.  This
  27. '                                  text will be left justified so use spaces
  28. '                                  if you want it in a special postion.
  29. '                    ReturnVal$ = the return value form user input
  30. '                    ftype% = 0 for alphanumeric, -1 for numeric values only
  31. '                    Exitkey% = the ASC number of the key that exited the
  32. '                               routine.  Use this to verify special functions.
  33. '
  34. 'NEXT VERSION IMPROVEMENTS: Minimum and maximum value validation with
  35. '                           automatic maximum validation from lenth of
  36. '                           mask$ if no maximum value is passed.  Will
  37. '                           also allow for commas and decimal places so
  38. '                           you can use the data returned with the PRINT
  39. '                           USING statement.
  40. '
  41. '   NOTES:  When I use this routine I define a global array for special
  42. '           keys.  This will let you to check for HELP of Allowable ENTER
  43. '           or EXIT keys like: F1 - F10; TAB; CURSOR UP/DOWN PGUP/DN ect.
  44. '           This allows you to exit the routine and take care of a request-
  45. '           ed function like HELP and then return the ReturnVal$ as the
  46. '           DefaultVal$ putting the user back where they left via the
  47. '           ReturnCurrentpos% value.
  48. '
  49. 'This is a Shareware product.  If you find it useful a donation of your
  50. 'choice 1$-10$ would be appreciated. I will be upgrading the product in
  51. 'the near future.  How soon depends on your response.
  52.  
  53. 'SEND DONATIONS AND/OR COMMENTS TO:
  54. '
  55. '                      SoftwareValue FLAP  ->(For Little As Possible)
  56. '                      7710 Swiss
  57. '                      Rowlett, TX 75088
  58. '                      (214)475-7586
  59. '
  60.  
  61.  
  62.  
  63.  
  64. '════════════════ These variables are a MUST for using MASKINPUT ══════════
  65. '************** DECLARE SOME COMMON VARIABLES **************
  66. COMMON slcolor%,Statrow%,Statcol%,lastkey%,normattr%,skcolor%,fieldchar%
  67. COMMON ReturnCurrentpos%
  68. '*************** DIM GLOBAL ARRAYS ****************
  69. DIM SHARED maskpos%(40,1), COLPOS%(80), FieldPos%(80)
  70. '*************** INCLUDE FILES NEEDED ********************
  71. REM $INCLUDE : 'STATLIN.INC'    ' Contains routine for CAPS INS SCRL NUM
  72. REM $INCLUDE : 'getkey.INC'     ' Loop for getting a key and updateing statlin
  73. REM $INCLUDE : 'status.inc'     ' Routine for displaying Status Line Messages
  74. '*********************************************************
  75. '═══════════════════════════ END OF MUST variables ══════════════════════
  76.  
  77. '************************ DEMO PROGRAM ********************
  78. Statrow%= 25: Statcol%=60: lastkey% = 1
  79. call calcattr(1,7,skcolor%):CALL CALCATTR(1,7,SLCOLOR%)
  80. call calcattr(15,1,normtext%): call calcattr(7,1,normattr%)
  81. row% = 5: col% = 10: call calcattr(1,7,attr%) : fg% = 7 : bg% = 1
  82. fieldchar% = 32
  83.  
  84. mask$ = "(   )   -    "    ' Our mask template for user input
  85. 'mask$ = space$(40)        ' Example of a blank field
  86. DefaultVal$ = "214"               ' This gives us a default area code for phone number
  87. ReturnVal$ = ""                  ' NULL new value
  88. color 15,1,1:cls           ' Set colors and clear screen
  89. CALL XQPRINT("F1 FOR MORE INFORMATION - ESC TO QUIT DEMO",1,1,15,0)
  90. call xqprint(space$(80),25,1,skcolor%,0)    'Make sure the status line is clear
  91.  
  92. '********************** SOME TEXT FOR THE DEMO *********************
  93. call xqprint("Parameters Passed :  mask$ = "+chr$(34)+"(  )   -    "+chr$(34),2,26,normtext%,0)
  94. call xqprint("default_value$ = "+chr$(34)+"214"+chr$(34),3,47,normtext%,0)
  95. call xqprint("Notice the 214 default and the cursor positioned at the",5,25,normtext%,0)
  96. call xqprint("first available space on the field ready for your input",6,25,normtext%,0)
  97. call xqprint("This is the status line for INS CAPS NUM & SCRL",23,33,normtext%,0)
  98. call xqprint(chr$(25)+"    "+chr$(25)+"    "+chr$(25)+"    "+chr$(25),24,62,normtext%,0)
  99. call xqprint("PHONE",5,4,normtext%,0)
  100.  
  101. call MASKINPUT(row%,col%,attr%,mask$,DefaultVal$,ReturnVal$,-1,Exitkey%)  'CALL MASKINPUT ROUTINE
  102. lnth% = LEN(ReturnVal$)
  103. call xqprint("The length of the value phone is "+STR$(lnth%),8,25,23,0)
  104. call xqprint("The returned value for phone is "+ReturnVal$,9,25,23,0)
  105. LOCATE 15,1,0 : color 7,1,1
  106. m1$ = "Notice how the returned value of phone is only the raw"
  107. m2$ = "data that you typed in and not any part of the mask$"
  108. m3$ = "value that you pased to the routine."
  109. call xqprint(m1$,11,25,normtext%,0) : call xqprint(m2$,12,25,normtext%,0)
  110. call xqprint(m3$,13,25,normtext%,0)
  111. call xqprint("Try Ctrl "+chr$(27)+" and Ctrl "+chr$(26)+" for next and previous word",16,1,normtext%,0)
  112. call xqprint("Try BACKSPACE with INSERT ON and INSERT OFF.  ALT-B will blank the field.",17,1,normtext%,0)
  113.  
  114. mask$ = space$(60)          'Use space$(n%) function for blank mask values
  115. DefaultVal$ = "Very good customer.  Expect large sales volume in 1988." 'default value
  116. call xqprint("COMMENT:",19,1,normtext%,0)
  117. call MASKINPUT(19,10,attr%,mask$,DefaultVal$,ReturnVal$,0,Exitkey%)
  118. call delay(1)       'delay 1 second
  119. COLOR 7,0,0 : CLS
  120. end                 'bye bye - end of demo
  121. '********************* END OF DEMO PROGRAM **************************
  122.  
  123.  
  124. '************************ THE MASKINPUT ROUTINE *********************
  125.  
  126. SUB MASKINPUT(row%,col%,attr%,mask$,DefaultVal$,ReturnVal$,ftype%,Exitkey%) STATIC
  127.     SHARED normattr%,slcolor%,statrow%,skcolor%,fieldchar%,fg%,bg%
  128.     SHARED ReturnCurrentpos%
  129.     color fg%,bg% : Fieldlen% = LEN(mask$): blankmask$ = STRING$(Fieldlen%,fieldchar%)
  130.     origcol% = col% : col% = col% + INSTR(DefaultVal$,chr$(fieldchar%)) - 1: noi% = 0
  131.     mpos% = 0 :  num.of.maskpos% = 0: Exitkey% = 0
  132.  
  133. FOR i% = 1 TO LEN(mask$)
  134.     a$ = MID$(mask$,i%,1)
  135.     IF ASC(a$) = FieldChar% THEN
  136.         noi% = noi% + 1
  137.         FieldPos%(noi%) = origcol%-1 + i%
  138.         tempmask$ = tempmask$ + chr$(fieldchar%)
  139.     ELSE
  140.         mpos% = mpos% + 1
  141.         maskpos%(mpos%,0) = origcol%-1 + i%
  142.         maskpos%(mpos%,1) = asc(a$)
  143.         tempmask$ = tempmask$ + a$
  144.     END IF
  145. NEXT i%
  146.  
  147. mask$ = tempmask$ : tempmask$ = ""
  148.  
  149. CALL XQPRINT(SPACE$(59),statrow%,1,slcolor%,0)
  150. CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
  151. CALL XQPRINT(mask$,row%,origcol%,attr%,0)
  152.  
  153. IF DefaultVal$ = "" THEN
  154.     DefaultVal$ = mask$
  155. ELSE
  156.     DefaultVal$ = LEFT$(DefaultVal$,noi%)
  157.     FOR i% = 1 TO LEN(DefaultVal$)
  158.         CALL XqPrint(MID$(DefaultVal$,i%,1),row%,FieldPos%(i%),attr%,0)
  159.     NEXT i%
  160.     ReturnVal$ = DefaultVal$
  161. END IF
  162.     IF ReturnCurrentpos% THEN
  163.         currentpos% = ReturnCurrentpos% : ReturnCurrentpos%=0
  164.     ELSE
  165.         IF len(ReturnVal$) = noi% THEN
  166.             currentpos% = 1
  167.         ELSE
  168.             currentpos% = len(ReturnVal$)+1
  169.             ReturnVal$ = ReturnVal$ + " "
  170.         END IF
  171.     END IF
  172.         LOCATE ROW%,FieldPos%(currentpos%),1
  173.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  174. GETKEYS:
  175.  
  176.         CALL GETCHAR(CH$) :IF stat% THEN CALL STATLINE("",stat%)
  177.         IF ASC(CH$) = 27 THEN COLOR 7,0,0 : CLS : END  'Remove this and define your own meaning
  178.         CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
  179.         IF LEN(ch$) = 2 THEN GOTO ExtendedKeys
  180.         ch% = ASC(ch$)
  181.         SELECT CASE ch%
  182.             CASE 27     'ESCAPE
  183.                 EXIT SUB ' remove or define you own meaning for Escape
  184.                 Exitkey% = 27
  185.             CASE 9      'TAB KEY  a forware movement enter key
  186.                 Exitkey% = 15 : GOTO EXITROUTINE
  187.             CASE 13     'ENTER
  188.                 EXITROUTINE:
  189.                 pf$ = ""
  190.                 FOR i% = origcol% to (origcol%+Fieldlen%-1)
  191.                     a% = screen(row%,i%)
  192.                     pf$ = pf$+chr$(a%)
  193.                 NEXT i%
  194.                 call xqprint(pf$+space$(Fieldlen%-len(pf$)),row%,origcol%,normattr%,0)
  195.                 IF Exitkey% = 0 THEN Exitkey% = 13
  196.                 EXIT SUB
  197.             CASE 8          'BACKSPACE
  198.                 oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  199.                 IF currentpos% = 1 THEN GOTO GETKEYS
  200.                 lastkey% = -1
  201.                 IF insert% THEN
  202.                     ReturnVal$ = left$(ReturnVal$,currentpos%-2) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  203.                     FOR i% = currentpos%-1 TO LEN(ReturnVal$)
  204.                         IF i% = 0 THEN GOTO BOL2        'Check for 0 value
  205.                         call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),attr%,0)
  206.                         BOL2:
  207.                     NEXT i%
  208.                     IF LEN(ReturnVal$) = noi% THEN
  209.                         call xqprint(chr$(fieldchar%),row%,fieldpos%(len(ReturnVal$)),attr%,0)
  210.                     ELSE
  211.                         call xqprint(chr$(fieldchar%),row%,fieldpos%(len(ReturnVal$)+1),attr%,0)
  212.                     END IF
  213.                     BOL3:
  214.                 ELSE
  215.                     ReturnVal$ = left$(ReturnVal$,currentpos%-2) + chr$(fieldchar%) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  216.                     call xqprint(chr$(fieldchar%),row%,fieldpos%(currentpos%-1),attr%,0)
  217.                 END IF
  218.                 GOSUB CHECKPOS
  219.                 LOCATE ,FieldPos%(currentpos%),1
  220.                 GOTO GETKEYS
  221.             CASE ELSE
  222.                 IF ftype% = -1 THEN  'If numeric only
  223.                     IF ASC(ch$) < 48 OR ASC(Ch$) > 57 THEN
  224.                         statmssg$ = "Input must be NUMBERS ONLY"
  225.                         CALL statline(statmssg$,stat%)
  226.                         GOTO GETKEYS
  227.                     END IF
  228.                 ELSE
  229.                     IF ASC(ch$) < 32  OR ASC(Ch$) > 127 THEN GOTO GETKEYS
  230.                 END IF
  231.                 lastkey% = 1: GOTO INSCH
  232.         END SELECT
  233.  
  234. INSCH:          'VERIFY LEN OF FIELD & INSERT KEY MODE & PRINT CHARACTER
  235.     IF insert% AND LEN(ReturnVal$) = NOI% THEN
  236.        oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  237.          IF RIGHT$(ReturnVal$,1) = chr$(fieldchar%) THEN
  238.             ReturnVal$ = left$(ReturnVal$,noi%-1)
  239.          ELSE
  240.             statmssg$ = "Input Field Is Full"
  241.             CALL statline(statmssg$,stat%)
  242.             CALL CLRKBD
  243.             GOTO GETKEYS
  244.          END IF
  245.     END IF
  246.     CALL XqPrint(ch$,row%,FieldPos%(currentpos%),attr%,0)
  247.     IF insert% THEN
  248.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  249.         ReturnVal$ = left$(ReturnVal$,currentpos%-1) + ch$ + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  250.         FOR i% = currentpos%+1 TO LEN(ReturnVal$)
  251.             CALL XqPrint(MID$(ReturnVal$,i%,1),row%,FieldPos%(i%),attr%,0)
  252.         NEXT i%
  253.     ELSE
  254.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  255.         new1$ = left$(ReturnVal$,currentpos%-1) + ch$
  256.         if len(ReturnVal$) > len(new1$) THEN
  257.             new2$ = right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
  258.         ELSE
  259.             new2$ = ""
  260.         END IF
  261.         ReturnVal$ = new1$ + new2$
  262.     END IF
  263.     currentpos% = currentpos% + (lastkey%)
  264.     IF currentpos% > noi% THEN currentpos% = noi%
  265.     LOCATE ,FieldPos%(currentpos%),1
  266.     GOTO GETKEYS
  267.  
  268. ExtendedKeys:                   'GET EXTENDED KEYS.  ADD OR CHANGE AS YOU NEED
  269.     extkey = ASC(RIGHT$(ch$,1))
  270.     SELECT CASE extkey
  271.         CASE 15     'SHIFT TAB a backware movement exit key or just a exit key
  272.             Exitkey% = 15 : GOTO EXITROUTINE
  273.  
  274.         CASE 22             'Alt-U   UNDO last command
  275.             if ReturnVal$ = oldReturnVal$ then goto getkeys
  276.             tempReturnVal$ = ReturnVal$ : tempcurrentpos% = currentpos%
  277.             call XqPrint(mask$,row%,origcol%,attr%,0)
  278.             IF noi% = LEN(mask$) THEN
  279.                 call XqPrint(oldReturnVal$,row%,origcol%,attr%,0)
  280.                 goto bottomofaltu
  281.             END IF
  282.             FOR i% = 1 TO LEN(oldReturnVal$)
  283.                 CALL XqPrint(MID$(oldReturnVal$,i%,1),row%,FieldPos%(i%),attr%,0)
  284.             NEXT i%
  285.             bottomofaltu:
  286.             ReturnVal$ = oldReturnVal$ : currentpos% = oldcurrentpos%
  287.             oldReturnVal$ = tempReturnVal$ : oldcurrentpos% = tempcurrentpos%
  288.             locate ,fieldpos%(currentpos%),1:  goto getkeys
  289.  
  290.         CASE 59                 'F1 REDEFINE FOR YOUR OWN USE
  291.             if sh% then color 7,1,1
  292.             REM $INCLUDE : 'MASK.HLP'       'HELP FILE FOR DEMO ONLY
  293.             'ReturnCurrentpos% = Currentpos% 'This is how you return the
  294.                                              'user back to exact cursor location.
  295.  
  296.         CASE 72     'CURSOR UP      a backward exit key
  297.             Exitkey% = 72  : GOTO EXITROUTINE
  298.  
  299.         CASE 80     'CURSOR DOWN    a foreward exit key
  300.             Exitkey% = 80  : GOTO EXITROUTINE
  301.  
  302.         CASE 117            'Ctrl-End Delete to end of line
  303.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  304.             ReturnVal$ = left$(ReturnVal$,currentpos%-1)+ " "
  305.             IF mpos% = 0 THEN
  306.                 call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),attr%,0)
  307.                 GOTO getkeys
  308.             END IF
  309.             call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),attr%,0)
  310.             FOR i% = 1 TO mpos%
  311.                 call XqPrint(chr$(maskpos%(i%,1)),row%,maskpos%(i%,0),attr%,0)
  312.             NEXT i%
  313.             GOTO getkeys
  314.  
  315.         CASE 75             'CURSOR-LEFT
  316.             lastkey% = -1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  317.             GOTO GETKEYS
  318.  
  319.         CASE 77         'CURSOR-RIGHT
  320.             IF currentpos% < LEN(ReturnVal$) THEN
  321.                 lastkey% = 1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  322.                 GOTO GETKEYS
  323.             ELSE
  324.                 IF RIGHT$(ReturnVal$,1) <> " " AND LEN(ReturnVal$) < noi% THEN
  325.                     ReturnVal$=ReturnVal$+" " : lastkey% = 1
  326.                     GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  327.                     GOTO GETKEYS
  328.                 END IF
  329.                 statmssg$ = "To move past your input use the SPACE BAR"
  330.                 CALL statline(statmssg$,stat%)
  331.                 GOTO GETKEYS
  332.             END IF
  333.  
  334.         CASE 71         'HOME KEY
  335.             LOCATE ,fieldpos%(1) : currentpos% = 1 : goto getkeys
  336.  
  337.         CASE 79         'END KEY
  338.             FOR char% = LEN(ReturnVal$) TO 1 STEP -1
  339.                 word$ = MID$(ReturnVal$, char%, 1)
  340.                 IF word$ <> chr$(fieldchar%) THEN
  341.                     EXIT FOR
  342.                 END IF
  343.             NEXT char%
  344.             IF MID$(ReturnVal$,char%+1,1) = chr$(fieldchar%) THEN
  345.                 char% = char% + 1 : GOTO BOEND
  346.             END IF
  347.             IF char% = LEN(ReturnVal$) AND char% <> noi% THEN
  348.                ReturnVal$ = ReturnVal$ + chr$(fieldchar%)
  349.                char% = LEN(ReturnVal$)
  350.             END IF
  351.             BOEND:
  352.             currentpos% = char%
  353.             lastkey% = 0
  354.             LOCATE ,fieldpos%(currentpos%) : goto getkeys
  355.  
  356.         CASE 83                     '**** DELETE KEY ****
  357.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  358.             IF LEN(ReturnVal$) = 0 THEN GOTO GETKEYS
  359.             IF currentpos% > LEN(ReturnVal$) THEN GOTO GETKEYS
  360.             IF currentpos% > 1 THEN
  361.                 ReturnVal$ = left$(ReturnVal$,currentpos%-1) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
  362.             ELSE
  363.                 ReturnVal$ = RIGHT$(ReturnVal$,len(ReturnVal$)-1)
  364.             END IF
  365.             lastkey% = 0
  366.             call xqprint(chr$(fieldchar%),row%,fieldpos%(len(ReturnVal$)+1),attr%,0)
  367.             FOR i% = currentpos% TO LEN(ReturnVal$)
  368.                 call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),attr%,0)
  369.             NEXT i%
  370.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  371.  
  372.         CASE 116            'Ctrl-Right Arrow - Next Word
  373.             lastkey% = 0
  374.             wordloc% = INSTR(currentpos%+1,ReturnVal$," ")
  375.             if wordloc% >= LEN(ReturnVal$) OR wordloc% = 0 THEN GOTO GETKEYS
  376.             FOR char% = wordloc% TO LEN(ReturnVal$)
  377.                 word$ = MID$(ReturnVal$, char%, 1)
  378.                 IF word$ <> " " THEN
  379.                     wordloc% = char%
  380.                     EXIT FOR
  381.                 END IF
  382.             NEXT char%
  383.             IF wordloc% > 1 AND wordloc% > currentpos%+1 THEN currentpos% = wordloc%
  384.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  385.  
  386.         CASE 115             'Ctrl-left Arrow - Next Word
  387.             CTAGAIN:
  388.             FOR char% = currentpos% TO 1 STEP -1
  389.                 word$ = MID$(ReturnVal$, char%, 1)
  390.                 IF word$ = " " AND char% < currentpos% THEN
  391.                     EXIT FOR
  392.                 END IF
  393.             NEXT char%
  394.             IF currentpos% - char% = 1 THEN
  395.                 currentpos% = currentpos% - 1
  396.                 GOTO CTAGAIN
  397.             END IF
  398.             currentpos% = char%+1
  399.             lastkey% = 0
  400.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  401.  
  402.         CASE 48                     'ALT-B  Blank Field
  403.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  404.             locate ,,0 : ReturnVal$ = mask$
  405.             CALL XqPRINT(mask$,row%,origcol%,attr%,0) :ReturnVal$ = ""
  406.             currentpos% = 1 :locate ,fieldpos%(1),1:  goto getkeys
  407.         CASE ELSE
  408.             GOTO GETKEYS        ' GO GET ANOTHER KEY FROM USER
  409.     END SELECT
  410.  
  411. Checkpos:
  412.     currentpos% = currentpos% + (lastkey%)
  413.     IF currentpos% < 1 THEN currentpos% = 1
  414.     IF currentpos% > noi% THEN currentpos% = noi%
  415. RETURN
  416. END SUB
  417.