home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
GLEN
/
MASK.ZIP
/
MASK.INC
< prev
next >
Wrap
Text File
|
1988-01-03
|
15KB
|
384 lines
' MASKINPUT
' (C) 1987 By Kevin L. Curtis
' 12/30/87
'
' Routine Name: MASKINPUT
' Version: 1.0
' Written by: Kevin L. Curtis
' Language: QuickBASIC 3.0
'
' Purpose: A highly versatile user input routine that uses
' a mask$ value passed much like the picture function
' in some popular Data Base products.
'
'******************** NOTE ** NOTE ** NOTE ** NOTE ** NOTE ** NOTE ***********
'
' MASKDEMO.EXE: Demo file for maskinput. For Green/Amber Graphics
' monitors such as Compaq, AT&T, use the command line
' MASKDEMO BW. This will make default colors black &
' white so you can read the screen without sunglasses.
'*****************************************************************************
'
' Example: mask$ = "( ) - " for phone number or
' mask$ = space$(40) for blank field.
'
'Parameters passed: row%,col%,FieldTextAttr%,mask$,DefaultVal$,ReturnVal$,
' ftype% = 0
' Where: row% = Row for field input.
' col% = Column for field input.
' FieldTextAttr% = Use ADVBAS CALL CALCATTR(foreground%,_
' background%,FieldTextAttr%) to get FieldTextAttr% value or
' (BACKGROUND * 16) + FOREGROUND = Attr%.
' mask$ = What ever you want your field to look like.
' " - - " or " / / "
' DefaultVal$ = the default value for the field. This
' text will be left justified so use spaces
' if you want it in a special postion.
' ReturnVal$ = the return value form user input
' ftype% = 0 for alphanumeric, -1 for numeric values only
' Exitkey% = the ASC number of the key that exited the
' routine. Use this to verify special functions.
'
'NEXT VERSION IMPROVEMENTS: Minimum and maximum value validation with
' automatic maximum validation from lenth of
' mask$ if no maximum value is passed. Will
' also allow for commas and decimal places so
' you can use the data returned with the PRINT
' USING statement.
'
' NOTES: When I use this routine I define a global array for special
' keys. This will let you to check for HELP of Allowable ENTER
' or EXIT keys like: F1 - F10; TAB; CURSOR UP/DOWN PGUP/DN ect.
' This allows you to exit the routine and take care of a request-
' ed function like HELP and then return the ReturnVal$ as the
' DefaultVal$ putting the user back where they left via the
' ReturnCurrentPOS% value.
'
'This is a Shareware product. If you find it useful a donation of your
'choice 1$-10$ would be appreciated. I will be upgrading the product in
'the near future. How soon depends on your response.
'
'If you upload this file to your favorite BBS, please leave these comments
'and instructions complete and intact. As for yourself, go ahead and delete
'all of the comments so you don't have to page down 20 times everytime you
'want to look at the source code.
'
'SEND DONATIONS AND/OR COMMENTS TO:
'
' SoftwareValue FLAP ->(For Little As Possible)
' 7710 Swiss
' Rowlett, TX 75088
' (214)475-7586
'
'════════════════ These variables are a MUST for using MASKINPUT ══════════
'************** DECLARE SOME COMMON VARIABLES **************
'COMMON SLColor%,StatRow%,StatCol%,LastKey%,NormAttr%,SkColor%,FieldChar%
'COMMON ReturnCurrentPOS%,FGColor%,BGColor%
'*************** DIM GLOBAL ARRAYS ****************
'DIM SHARED maskpos%(40,1), COLPOS%(80), FieldPos%(80)
'*************** INCLUDE FILES NEEDED ********************
'REM $INCLUDE : 'STATLIN.INC' ' Contains routine for CAPS INS SCRL NUM
'REM $INCLUDE : 'GETKEY.INC' ' Loop for getting a key and updateing statlin
'REM $INCLUDE : 'STATUS.INC' ' Routine for displaying Status Line Messages
'REM $INCLUDE : 'GETVIDMO.INC' ' Returns the Video Mode
'*********************************************************
'═══════════════════════════ END OF MUST variables ══════════════════════
'************************ THE MASKINPUT SUB ROUTINE *********************
SUB MASKINPUT(row%,col%,FieldTextAttr%,mask$,DefaultVal$,ReturnVal$,ftype%,Exitkey%) STATIC
SHARED NormAttr%,SLColor%,StatRow%,SkColor%,FieldChar%,FGColor%,BGColor%
SHARED ReturnCurrentPOS%
COLOR FGColor%,BGColor% : Fieldlen% = LEN(mask$): blankmask$ = STRING$(Fieldlen%,FieldChar%)
origcol% = col% : col% = col% + INSTR(DefaultVal$,chr$(FieldChar%)) - 1: noi% = 0
mpos% = 0 : num.of.maskpos% = 0: Exitkey% = 0
FOR i% = 1 TO LEN(mask$)
a$ = MID$(mask$,i%,1)
IF ASC(a$) = FieldChar% THEN
noi% = noi% + 1
FieldPos%(noi%) = origcol%-1 + i%
tempmask$ = tempmask$ + chr$(FieldChar%)
ELSE
mpos% = mpos% + 1
maskpos%(mpos%,0) = origcol%-1 + i%
maskpos%(mpos%,1) = asc(a$)
tempmask$ = tempmask$ + a$
END IF
NEXT i%
mask$ = tempmask$ : tempmask$ = ""
CALL XQPRINT(SPACE$(59),StatRow%,1,SLColor%,0)
CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
CALL XQPRINT(mask$,row%,origcol%,FieldTextAttr%,0)
IF DefaultVal$ = "" THEN
DefaultVal$ = mask$
ELSE
DefaultVal$ = LEFT$(DefaultVal$,noi%)
FOR i% = 1 TO LEN(DefaultVal$)
CALL XqPrint(MID$(DefaultVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
NEXT i%
ReturnVal$ = DefaultVal$
END IF
IF ReturnCurrentPOS% THEN
currentpos% = ReturnCurrentPOS% : ReturnCurrentPOS%=0
ELSE
IF len(ReturnVal$) = noi% THEN
currentpos% = 1
ELSE
currentpos% = len(ReturnVal$)+1
ReturnVal$ = ReturnVal$ + " "
END IF
END IF
LOCATE ROW%,FieldPos%(currentpos%),1
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
GETKEYS:
CALL GETCHAR(CH$) :IF stat% THEN CALL STATLINE("",stat%)
IF ASC(CH$) = 27 THEN COLOR 7,0,0 : CLS : END 'Remove this and define your own meaning
CALL GETKBD(insert%,capslock%,numlock%,scrolllock%)
IF LEN(ch$) = 2 THEN GOTO ExtendedKeys
ch% = ASC(ch$)
SELECT CASE ch%
CASE 27 'ESCAPE
EXIT SUB ' remove or define you own meaning for Escape
Exitkey% = 27
CASE 9 'TAB KEY a forware movement enter key
Exitkey% = 15 : GOTO EXITROUTINE
CASE 13 'ENTER
EXITROUTINE:
pf$ = ""
FOR i% = origcol% to (origcol%+Fieldlen%-1)
a% = screen(row%,i%)
pf$ = pf$+chr$(a%)
NEXT i%
call xqprint(pf$+space$(Fieldlen%-len(pf$)),row%,origcol%,NormAttr%,0)
IF Exitkey% = 0 THEN Exitkey% = 13
EXIT SUB
CASE 8 'BACKSPACE
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
IF currentpos% = 1 THEN GOTO GETKEYS
LastKey% = -1
IF insert% THEN
ReturnVal$ = left$(ReturnVal$,currentpos%-2) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
FOR i% = currentpos%-1 TO LEN(ReturnVal$)
IF i% = 0 THEN GOTO BOL2 'Check for 0 value
call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),FieldTextAttr%,0)
BOL2:
NEXT i%
IF LEN(ReturnVal$) = noi% THEN
call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)),FieldTextAttr%,0)
ELSE
call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)+1),FieldTextAttr%,0)
END IF
BOL3:
ELSE
ReturnVal$ = left$(ReturnVal$,currentpos%-2) + chr$(FieldChar%) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
call xqprint(chr$(FieldChar%),row%,fieldpos%(currentpos%-1),FieldTextAttr%,0)
END IF
GOSUB CHECKPOS
LOCATE ,FieldPos%(currentpos%),1
GOTO GETKEYS
CASE ELSE
IF ftype% = -1 THEN 'IF numeric only
IF ASC(ch$) < 48 OR ASC(Ch$) > 57 THEN
statmssg$ = "Input must be NUMBERS ONLY"
CALL statline(statmssg$,stat%)
GOTO GETKEYS
END IF
ELSE
IF ASC(ch$) < 32 OR ASC(Ch$) > 127 THEN GOTO GETKEYS
END IF
LastKey% = 1: GOTO INSCH
END SELECT
INSCH: 'VERIFY LEN OF FIELD & INSERT KEY MODE & PRINT CHARACTER
IF insert% AND LEN(ReturnVal$) = NOI% THEN
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
IF RIGHT$(ReturnVal$,1) = chr$(FieldChar%) THEN
ReturnVal$ = left$(ReturnVal$,noi%-1)
ELSE
statmssg$ = "Input Field Is Full"
CALL statline(statmssg$,stat%)
CALL CLRKBD
GOTO GETKEYS
END IF
END IF
CALL XqPrint(ch$,row%,FieldPos%(currentpos%),FieldTextAttr%,0)
IF insert% THEN
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
ReturnVal$ = left$(ReturnVal$,currentpos%-1) + ch$ + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%-1))
FOR i% = currentpos%+1 TO LEN(ReturnVal$)
CALL XqPrint(MID$(ReturnVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
NEXT i%
ELSE
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
new1$ = left$(ReturnVal$,currentpos%-1) + ch$
IF len(ReturnVal$) > len(new1$) THEN
new2$ = right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
ELSE
new2$ = ""
END IF
ReturnVal$ = new1$ + new2$
END IF
currentpos% = currentpos% + (LastKey%)
IF currentpos% > noi% THEN currentpos% = noi%
LOCATE ,FieldPos%(currentpos%),1
GOTO GETKEYS
ExtendedKeys: 'GET EXTENDED KEYS. ADD OR CHANGE AS YOU NEED
extkey = ASC(RIGHT$(ch$,1))
SELECT CASE extkey
CASE 15 'SHIFT TAB a backware movement exit key or just a exit key
Exitkey% = 15 : GOTO EXITROUTINE
CASE 22 'Alt-U UNDO last command
IF ReturnVal$ = oldReturnVal$ THEN goto getkeys
tempReturnVal$ = ReturnVal$ : tempcurrentpos% = currentpos%
call XqPrint(mask$,row%,origcol%,FieldTextAttr%,0)
IF noi% = LEN(mask$) THEN
call XqPrint(oldReturnVal$,row%,origcol%,FieldTextAttr%,0)
goto bottomofaltu
END IF
FOR i% = 1 TO LEN(oldReturnVal$)
CALL XqPrint(MID$(oldReturnVal$,i%,1),row%,FieldPos%(i%),FieldTextAttr%,0)
NEXT i%
bottomofaltu:
ReturnVal$ = oldReturnVal$ : currentpos% = oldcurrentpos%
oldReturnVal$ = tempReturnVal$ : oldcurrentpos% = tempcurrentpos%
locate ,fieldpos%(currentpos%),1: goto getkeys
CASE 59 'F1 REDEFINE FOR YOUR OWN USE
IF sh% THEN COLOR FGColor%,BGColor%,BGColor%
REM $INCLUDE : 'MASK.HLP' 'HELP FILE FOR DEMO ONLY
'ReturnCurrentPOS% = Currentpos% 'This is how you return the
'user back to exact cursor location.
CASE 72 'CURSOR UP a backward exit key
Exitkey% = 72 : GOTO EXITROUTINE
CASE 80 'CURSOR DOWN a foreward exit key
Exitkey% = 80 : GOTO EXITROUTINE
CASE 117 'Ctrl-End Delete to end of line
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
ReturnVal$ = left$(ReturnVal$,currentpos%-1)+ " "
IF mpos% = 0 THEN
call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),FieldTextAttr%,0)
GOTO getkeys
END IF
call XqPrint(space$(origcol%+LEN(mask$)-POS(0)),row%,pos(0),FieldTextAttr%,0)
FOR i% = 1 TO mpos%
call XqPrint(chr$(maskpos%(i%,1)),row%,maskpos%(i%,0),FieldTextAttr%,0)
NEXT i%
GOTO getkeys
CASE 75 'CURSOR-LEFT
LastKey% = -1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
GOTO GETKEYS
CASE 77 'CURSOR-RIGHT
IF currentpos% < LEN(ReturnVal$) THEN
LastKey% = 1 : GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
GOTO GETKEYS
ELSE
IF RIGHT$(ReturnVal$,1) <> " " AND LEN(ReturnVal$) < noi% THEN
ReturnVal$=ReturnVal$+" " : LastKey% = 1
GOSUB CHECKPOS: LOCATE ,FieldPos%(currentpos%),1
GOTO GETKEYS
END IF
statmssg$ = "To move past your input use the SPACE BAR"
CALL statline(statmssg$,stat%)
GOTO GETKEYS
END IF
CASE 71 'HOME KEY
LOCATE ,fieldpos%(1) : currentpos% = 1 : goto getkeys
CASE 79 'END KEY
FOR char% = LEN(ReturnVal$) TO 1 STEP -1
word$ = MID$(ReturnVal$, char%, 1)
IF word$ <> chr$(FieldChar%) THEN
EXIT FOR
END IF
NEXT char%
IF MID$(ReturnVal$,char%+1,1) = chr$(FieldChar%) THEN
char% = char% + 1 : GOTO BOEND
END IF
IF char% = LEN(ReturnVal$) AND char% <> noi% THEN
ReturnVal$ = ReturnVal$ + chr$(FieldChar%)
char% = LEN(ReturnVal$)
END IF
BOEND:
currentpos% = char%
LastKey% = 0
LOCATE ,fieldpos%(currentpos%) : goto getkeys
CASE 83 '**** DELETE KEY ****
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
IF LEN(ReturnVal$) = 0 THEN GOTO GETKEYS
IF currentpos% > LEN(ReturnVal$) THEN GOTO GETKEYS
IF currentpos% > 1 THEN
ReturnVal$ = left$(ReturnVal$,currentpos%-1) + right$(ReturnVal$, LEN(ReturnVal$) - (currentpos%))
ELSE
ReturnVal$ = RIGHT$(ReturnVal$,len(ReturnVal$)-1)
END IF
LastKey% = 0
call xqprint(chr$(FieldChar%),row%,fieldpos%(len(ReturnVal$)+1),FieldTextAttr%,0)
FOR i% = currentpos% TO LEN(ReturnVal$)
call xqprint(mid$(ReturnVal$,i%,1),row%,fieldpos%(i%),FieldTextAttr%,0)
NEXT i%
GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
CASE 116 'Ctrl-Right Arrow - Next Word
LastKey% = 0
wordloc% = INSTR(currentpos%+1,ReturnVal$," ")
IF wordloc% >= LEN(ReturnVal$) OR wordloc% = 0 THEN GOTO GETKEYS
FOR char% = wordloc% TO LEN(ReturnVal$)
word$ = MID$(ReturnVal$, char%, 1)
IF word$ <> " " THEN
wordloc% = char%
EXIT FOR
END IF
NEXT char%
IF wordloc% > 1 AND wordloc% > currentpos%+1 THEN currentpos% = wordloc%
GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
CASE 115 'Ctrl-left Arrow - Next Word
CTAGAIN:
FOR char% = currentpos% TO 1 STEP -1
word$ = MID$(ReturnVal$, char%, 1)
IF word$ = " " AND char% < currentpos% THEN
EXIT FOR
END IF
NEXT char%
IF currentpos% - char% = 1 THEN
currentpos% = currentpos% - 1
GOTO CTAGAIN
END IF
currentpos% = char%+1
LastKey% = 0
GOSUB CHECKPOS : LOCATE ,FieldPos%(currentpos%),1 : GOTO GETKEYS
CASE 48 'ALT-B Blank Field
oldReturnVal$ = ReturnVal$ : oldcurrentpos% = currentpos%
locate ,,0 : ReturnVal$ = mask$
CALL XqPRINT(mask$,row%,origcol%,FieldTextAttr%,0) :ReturnVal$ = ""
currentpos% = 1 :locate ,fieldpos%(1),1: goto getkeys
CASE ELSE
GOTO GETKEYS ' GO GET ANOTHER KEY FROM USER
END SELECT
Checkpos: 'CHECK THE CURSOR POSITION BEING REQUESTED AND RETURN
currentpos% = currentpos% + (LastKey%)
IF currentpos% < 1 THEN currentpos% = 1
IF currentpos% > noi% THEN currentpos% = noi%
RETURN
END SUB