home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / window / mask10 / mask.inc < prev    next >
Encoding:
Text File  |  1988-01-02  |  14.8 KB  |  384 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. '******************** NOTE ** NOTE ** NOTE ** NOTE ** NOTE ** NOTE ***********
  15. '
  16. '     MASKDEMO.EXE:  Demo file for maskinput.  For Green/Amber Graphics
  17. '                    monitors such as Compaq, AT&T, use the command line
  18. '                    MASKDEMO BW.  This will make default colors black &
  19. '                    white so you can read the screen without sunglasses.
  20. '*****************************************************************************
  21. '
  22. '          Example:  mask$ = "(   )   -    "   for phone number or
  23. '                    mask$ = space$(40)        for blank field.
  24. '
  25. 'Parameters passed:  row%,col%,FieldTextAttr%,mask$,DefaultVal$,ReturnVal$,
  26. '                     ftype% = 0
  27. '            Where:  row% = Row for field input.
  28. '                    col% = Column for field input.
  29. '                    FieldTextAttr% = Use ADVBAS CALL CALCATTR(foreground%,_
  30. '                            background%,FieldTextAttr%) to get FieldTextAttr% value or
  31. '                            (BACKGROUND * 16) + FOREGROUND = Attr%.
  32. '                    mask$ = What ever you want your field to look like.
  33. '                            "   -  -   " or "  /  /  "
  34. '                    DefaultVal$ = the default value for the field.  This
  35. '                                  text will be left justified so use spaces
  36. '                                  if you want it in a special postion.
  37. '                    ReturnVal$ = the return value form user input
  38. '                    ftype% = 0 for alphanumeric, -1 for numeric values only
  39. '                    Exitkey% = the ASC number of the key that exited the
  40. '                               routine.  Use this to verify special functions.
  41. '
  42. 'NEXT VERSION IMPROVEMENTS: Minimum and maximum value validation with
  43. '                           automatic maximum validation from lenth of
  44. '                           mask$ if no maximum value is passed.  Will
  45. '                           also allow for commas and decimal places so
  46. '                           you can use the data returned with the PRINT
  47. '                           USING statement.
  48. '
  49. '   NOTES:  When I use this routine I define a global array for special
  50. '           keys.  This will let you to check for HELP of Allowable ENTER
  51. '           or EXIT keys like: F1 - F10; TAB; CURSOR UP/DOWN PGUP/DN ect.
  52. '           This allows you to exit the routine and take care of a request-
  53. '           ed function like HELP and then return the ReturnVal$ as the
  54. '           DefaultVal$ putting the user back where they left via the
  55. '           ReturnCurrentPOS% value.
  56. '
  57. 'This is a Shareware product.  If you find it useful a donation of your
  58. 'choice 1$-10$ would be appreciated. I will be upgrading the product in
  59. 'the near future.  How soon depends on your response.
  60. '
  61. 'If you upload this file to your favorite BBS, please leave these comments
  62. 'and instructions complete and intact.  As for yourself, go ahead and delete
  63. 'all of the comments so you don't have to page down 20 times everytime you
  64. 'want to look at the source code.
  65. '
  66. 'SEND DONATIONS AND/OR COMMENTS TO:
  67. '
  68. '                      SoftwareValue FLAP  ->(For Little As Possible)
  69. '                      7710 Swiss
  70. '                      Rowlett, TX 75088
  71. '                      (214)475-7586
  72. '
  73.  
  74.  
  75.  
  76.  
  77. '════════════════ These variables are a MUST for using MASKINPUT ══════════
  78. '************** DECLARE SOME COMMON VARIABLES **************
  79. 'COMMON SLColor%,StatRow%,StatCol%,LastKey%,NormAttr%,SkColor%,FieldChar%
  80. 'COMMON ReturnCurrentPOS%,FGColor%,BGColor%
  81. '*************** DIM GLOBAL ARRAYS ****************
  82. 'DIM SHARED maskpos%(40,1), COLPOS%(80), FieldPos%(80)
  83. '*************** INCLUDE FILES NEEDED ********************
  84. 'REM $INCLUDE : 'STATLIN.INC'    ' Contains routine for CAPS INS SCRL NUM
  85. 'REM $INCLUDE : 'GETKEY.INC'     ' Loop for getting a key and updateing statlin
  86. 'REM $INCLUDE : 'STATUS.INC'     ' Routine for displaying Status Line Messages
  87. 'REM $INCLUDE : 'GETVIDMO.INC'   ' Returns the Video Mode
  88. '*********************************************************
  89. '═══════════════════════════ END OF MUST variables ══════════════════════
  90.  
  91. '************************ THE MASKINPUT SUB ROUTINE *********************
  92.  
  93. SUB MASKINPUT(row%,col%,FieldTextAttr%,mask$,DefaultVal$,ReturnVal$,ftype%,Exitkey%) STATIC
  94.     SHARED NormAttr%,SLColor%,StatRow%,SkColor%,FieldChar%,FGColor%,BGColor%
  95.     SHARED ReturnCurrentPOS%
  96.     COLOR FGColor%,BGColor% : Fieldlen% = LEN(mask$): blankmask$ = STRING$(Fieldlen%,FieldChar%)
  97.     origcol% = col% : col% = col% + INSTR(DefaultVal$,chr$(FieldChar%)) - 1: noi% = 0
  98.     mpos% = 0 :  num.of.maskpos% = 0: Exitkey% = 0
  99.  
  100. FOR i% = 1 TO LEN(mask$)
  101.     a$ = MID$(mask$,i%,1)
  102.     IF ASC(a$) = FieldChar% THEN
  103.         noi% = noi% + 1
  104.         FieldPos%(noi%) = origcol%-1 + i%
  105.         tempmask$ = tempmask$ + chr$(FieldChar%)
  106.     ELSE
  107.         mpos% = mpos% + 1
  108.         maskpos%(mpos%,0) = origcol%-1 + i%
  109.         maskpos%(mpos%,1) = asc(a$)
  110.         tempmask$ = tempmask$ + a$
  111.     END IF
  112. NEXT i%
  113.  
  114. mask$ = tempmask$ : tempmask$ = ""
  115.  
  116. CALL XQPRINT(SPACE$(59),StatRow%,1,SLColor%,0)
  117. CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
  118. CALL XQPRINT(mask$,row%,origcol%,FieldTextAttr%,0)
  119.  
  120. IF DefaultVal$ = "" THEN
  121.     DefaultVal$ = mask$
  122. ELSE
  123.     DefaultVal$ = LEFT$(DefaultVal$,noi%)
  124.     FOR i% = 1 TO LEN(DefaultVal$)
  125.         CALL XqPrint(MID$(DefaultVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
  126.     NEXT i%
  127.     ReturnVal$ = DefaultVal$
  128. END IF
  129.     IF ReturnCurrentPOS% THEN
  130.         currentpos% = ReturnCurrentPOS% : ReturnCurrentPOS%=0
  131.     ELSE
  132.         IF len(ReturnVal$) = noi% THEN
  133.             currentpos% = 1
  134.         ELSE
  135.             currentpos% = len(ReturnVal$)+1
  136.             ReturnVal$ = ReturnVal$ + " "
  137.         END IF
  138.     END IF
  139.         LOCATE ROW%,FieldPos%(currentpos%),1
  140.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  141. GETKEYS:
  142.  
  143.         CALL GETCHAR(CH$) :IF stat% THEN CALL STATLINE("",stat%)
  144.         IF ASC(CH$) = 27 THEN COLOR 7,0,0 : CLS : END  'Remove this and define your own meaning
  145.         CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
  146.         IF LEN(ch$) = 2 THEN GOTO ExtendedKeys
  147.         ch% = ASC(ch$)
  148.         SELECT CASE ch%
  149.             CASE 27     'ESCAPE
  150.                 EXIT SUB ' remove or define you own meaning for Escape
  151.                 Exitkey% = 27
  152.             CASE 9      'TAB KEY  a forware movement enter key
  153.                 Exitkey% = 15 : GOTO EXITROUTINE
  154.             CASE 13     'ENTER
  155.                 EXITROUTINE:
  156.                 pf$ = ""
  157.                 FOR i% = origcol% to (origcol%+Fieldlen%-1)
  158.                     a% = screen(row%,i%)
  159.                     pf$ = pf$+chr$(a%)
  160.                 NEXT i%
  161.                 call xqprint(pf$+space$(Fieldlen%-len(pf$)),row%,origcol%,NormAttr%,0)
  162.                 IF Exitkey% = 0 THEN Exitkey% = 13
  163.                 EXIT SUB
  164.             CASE 8          'BACKSPACE
  165.                 oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  166.                 IF currentpos% = 1 THEN GOTO GETKEYS
  167.                 LastKey% = -1
  168.                 IF insert% THEN
  169.                     ReturnVal$ = left$(ReturnVal$,currentpos%-2) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  170.                     FOR i% = currentpos%-1 TO LEN(ReturnVal$)
  171.                         IF i% = 0 THEN GOTO BOL2        'Check for 0 value
  172.                         call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),FieldTextAttr%,0)
  173.                         BOL2:
  174.                     NEXT i%
  175.                     IF LEN(ReturnVal$) = noi% THEN
  176.                         call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)),FieldTextAttr%,0)
  177.                     ELSE
  178.                         call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)+1),FieldTextAttr%,0)
  179.                     END IF
  180.                     BOL3:
  181.                 ELSE
  182.                     ReturnVal$ = left$(ReturnVal$,currentpos%-2) + chr$(FieldChar%) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  183.                     call xqprint(chr$(FieldChar%),row%,fieldpos%(currentpos%-1),FieldTextAttr%,0)
  184.                 END IF
  185.                 GOSUB CHECKPOS
  186.                 LOCATE ,FieldPos%(currentpos%),1
  187.                 GOTO GETKEYS
  188.             CASE ELSE
  189.                 IF ftype% = -1 THEN  'IF numeric only
  190.                     IF ASC(ch$) < 48 OR ASC(Ch$) > 57 THEN
  191.                         statmssg$ = "Input must be NUMBERS ONLY"
  192.                         CALL statline(statmssg$,stat%)
  193.                         GOTO GETKEYS
  194.                     END IF
  195.                 ELSE
  196.                     IF ASC(ch$) < 32  OR ASC(Ch$) > 127 THEN GOTO GETKEYS
  197.                 END IF
  198.                 LastKey% = 1: GOTO INSCH
  199.         END SELECT
  200.  
  201. INSCH:          'VERIFY LEN OF FIELD & INSERT KEY MODE & PRINT CHARACTER
  202.     IF insert% AND LEN(ReturnVal$) = NOI% THEN
  203.        oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  204.          IF RIGHT$(ReturnVal$,1) = chr$(FieldChar%) THEN
  205.             ReturnVal$ = left$(ReturnVal$,noi%-1)
  206.          ELSE
  207.             statmssg$ = "Input Field Is Full"
  208.             CALL statline(statmssg$,stat%)
  209.             CALL CLRKBD
  210.             GOTO GETKEYS
  211.          END IF
  212.     END IF
  213.     CALL XqPrint(ch$,row%,FieldPos%(currentpos%),FieldTextAttr%,0)
  214.     IF insert% THEN
  215.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  216.         ReturnVal$ = left$(ReturnVal$,currentpos%-1) + ch$ + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
  217.         FOR i% = currentpos%+1 TO LEN(ReturnVal$)
  218.             CALL XqPrint(MID$(ReturnVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
  219.         NEXT i%
  220.     ELSE
  221.         oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  222.         new1$ = left$(ReturnVal$,currentpos%-1) + ch$
  223.         IF len(ReturnVal$) > len(new1$) THEN
  224.             new2$ = right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
  225.         ELSE
  226.             new2$ = ""
  227.         END IF
  228.         ReturnVal$ = new1$ + new2$
  229.     END IF
  230.     currentpos% = currentpos% + (LastKey%)
  231.     IF currentpos% > noi% THEN currentpos% = noi%
  232.     LOCATE ,FieldPos%(currentpos%),1
  233.     GOTO GETKEYS
  234.  
  235. ExtendedKeys:                   'GET EXTENDED KEYS.  ADD OR CHANGE AS YOU NEED
  236.     extkey = ASC(RIGHT$(ch$,1))
  237.     SELECT CASE extkey
  238.         CASE 15     'SHIFT TAB a backware movement exit key or just a exit key
  239.             Exitkey% = 15 : GOTO EXITROUTINE
  240.  
  241.         CASE 22             'Alt-U   UNDO last command
  242.             IF ReturnVal$ = oldReturnVal$ THEN goto getkeys
  243.             tempReturnVal$ = ReturnVal$ : tempcurrentpos% = currentpos%
  244.             call XqPrint(mask$,row%,origcol%,FieldTextAttr%,0)
  245.             IF noi% = LEN(mask$) THEN
  246.                 call XqPrint(oldReturnVal$,row%,origcol%,FieldTextAttr%,0)
  247.                 goto bottomofaltu
  248.             END IF
  249.             FOR i% = 1 TO LEN(oldReturnVal$)
  250.                 CALL XqPrint(MID$(oldReturnVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
  251.             NEXT i%
  252.             bottomofaltu:
  253.             ReturnVal$ = oldReturnVal$ : currentpos% = oldcurrentpos%
  254.             oldReturnVal$ = tempReturnVal$ : oldcurrentpos% = tempcurrentpos%
  255.             locate ,fieldpos%(currentpos%),1:  goto getkeys
  256.  
  257.         CASE 59                 'F1 REDEFINE FOR YOUR OWN USE
  258.             IF sh% THEN COLOR FGColor%,BGColor%,BGColor%
  259.             REM $INCLUDE : 'MASK.HLP'       'HELP FILE FOR DEMO ONLY
  260.             'ReturnCurrentPOS% = Currentpos% 'This is how you return the
  261.                                              'user back to exact cursor location.
  262.  
  263.         CASE 72     'CURSOR UP      a backward exit key
  264.             Exitkey% = 72  : GOTO EXITROUTINE
  265.  
  266.         CASE 80     'CURSOR DOWN    a foreward exit key
  267.             Exitkey% = 80  : GOTO EXITROUTINE
  268.  
  269.         CASE 117            'Ctrl-End Delete to end of line
  270.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  271.             ReturnVal$ = left$(ReturnVal$,currentpos%-1)+ " "
  272.             IF mpos% = 0 THEN
  273.                 call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),FieldTextAttr%,0)
  274.                 GOTO getkeys
  275.             END IF
  276.             call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),FieldTextAttr%,0)
  277.             FOR i% = 1 TO mpos%
  278.                 call XqPrint(chr$(maskpos%(i%,1)),row%,maskpos%(i%,0),FieldTextAttr%,0)
  279.             NEXT i%
  280.             GOTO getkeys
  281.  
  282.         CASE 75             'CURSOR-LEFT
  283.             LastKey% = -1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  284.             GOTO GETKEYS
  285.  
  286.         CASE 77         'CURSOR-RIGHT
  287.             IF currentpos% < LEN(ReturnVal$) THEN
  288.                 LastKey% = 1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  289.                 GOTO GETKEYS
  290.             ELSE
  291.                 IF RIGHT$(ReturnVal$,1) <> " " AND LEN(ReturnVal$) < noi% THEN
  292.                     ReturnVal$=ReturnVal$+" " : LastKey% = 1
  293.                     GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
  294.                     GOTO GETKEYS
  295.                 END IF
  296.                 statmssg$ = "To move past your input use the SPACE BAR"
  297.                 CALL statline(statmssg$,stat%)
  298.                 GOTO GETKEYS
  299.             END IF
  300.  
  301.         CASE 71         'HOME KEY
  302.             LOCATE ,fieldpos%(1) : currentpos% = 1 : goto getkeys
  303.  
  304.         CASE 79         'END KEY
  305.             FOR char% = LEN(ReturnVal$) TO 1 STEP -1
  306.                 word$ = MID$(ReturnVal$, char%, 1)
  307.                 IF word$ <> chr$(FieldChar%) THEN
  308.                     EXIT FOR
  309.                 END IF
  310.             NEXT char%
  311.             IF MID$(ReturnVal$,char%+1,1) = chr$(FieldChar%) THEN
  312.                 char% = char% + 1 : GOTO BOEND
  313.             END IF
  314.             IF char% = LEN(ReturnVal$) AND char% <> noi% THEN
  315.                ReturnVal$ = ReturnVal$ + chr$(FieldChar%)
  316.                char% = LEN(ReturnVal$)
  317.             END IF
  318.             BOEND:
  319.             currentpos% = char%
  320.             LastKey% = 0
  321.             LOCATE ,fieldpos%(currentpos%) : goto getkeys
  322.  
  323.         CASE 83                     '**** DELETE KEY ****
  324.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  325.             IF LEN(ReturnVal$) = 0 THEN GOTO GETKEYS
  326.             IF currentpos% > LEN(ReturnVal$) THEN GOTO GETKEYS
  327.             IF currentpos% > 1 THEN
  328.                 ReturnVal$ = left$(ReturnVal$,currentpos%-1) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
  329.             ELSE
  330.                 ReturnVal$ = RIGHT$(ReturnVal$,len(ReturnVal$)-1)
  331.             END IF
  332.             LastKey% = 0
  333.             call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)+1),FieldTextAttr%,0)
  334.             FOR i% = currentpos% TO LEN(ReturnVal$)
  335.                 call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),FieldTextAttr%,0)
  336.             NEXT i%
  337.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  338.  
  339.         CASE 116            'Ctrl-Right Arrow - Next Word
  340.             LastKey% = 0
  341.             wordloc% = INSTR(currentpos%+1,ReturnVal$," ")
  342.             IF wordloc% >= LEN(ReturnVal$) OR wordloc% = 0 THEN GOTO GETKEYS
  343.             FOR char% = wordloc% TO LEN(ReturnVal$)
  344.                 word$ = MID$(ReturnVal$, char%, 1)
  345.                 IF word$ <> " " THEN
  346.                     wordloc% = char%
  347.                     EXIT FOR
  348.                 END IF
  349.             NEXT char%
  350.             IF wordloc% > 1 AND wordloc% > currentpos%+1 THEN currentpos% = wordloc%
  351.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  352.  
  353.         CASE 115             'Ctrl-left Arrow - Next Word
  354.             CTAGAIN:
  355.             FOR char% = currentpos% TO 1 STEP -1
  356.                 word$ = MID$(ReturnVal$, char%, 1)
  357.                 IF word$ = " " AND char% < currentpos% THEN
  358.                     EXIT FOR
  359.                 END IF
  360.             NEXT char%
  361.             IF currentpos% - char% = 1 THEN
  362.                 currentpos% = currentpos% - 1
  363.                 GOTO CTAGAIN
  364.             END IF
  365.             currentpos% = char%+1
  366.             LastKey% = 0
  367.             GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
  368.  
  369.         CASE 48                     'ALT-B  Blank Field
  370.             oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
  371.             locate ,,0 : ReturnVal$ = mask$
  372.             CALL XqPRINT(mask$,row%,origcol%,FieldTextAttr%,0) :ReturnVal$ = ""
  373.             currentpos% = 1 :locate ,fieldpos%(1),1:  goto getkeys
  374.         CASE ELSE
  375.             GOTO GETKEYS        ' GO GET ANOTHER KEY FROM USER
  376.     END SELECT
  377.  
  378. Checkpos:               'CHECK THE CURSOR POSITION BEING REQUESTED AND RETURN
  379.     currentpos% = currentpos% + (LastKey%)
  380.     IF currentpos% < 1 THEN currentpos% = 1
  381.     IF currentpos% > noi% THEN currentpos% = noi%
  382. RETURN
  383. END SUB
  384.