nun ich suche schon seit 2 tagen eine vernüftige input routine sowie eine Eingabemaske leider ohne erfolg. Ich habe hier welche in Qbasic die das erfüllen was ich brauche, nimmt aber Pure Basic leider nicht an.
Wäre toll wenn mir einer helfen könnte mir die unten 2 aufgeführten Routinen die in Qbasick geschrieben sind in Pure Basic zu übersetzen.
Code: Alles auswählen
*************** Input Routine in Qbasic ***********************
' Row - The Row for the textbox to be printed
' Col - The Column for the textbox to be printed
' PasswordChar$ - Character to be printed instead of
' text. It'll print the text if it's
' left blank.
' MaxWidth - The Maximum width that the user can type
' NOTE: This will not be affected if there
' is a mask.
' Fore - Foreground color of the text
' Back - Background color of the text
' Empty$ - The character to be printed in the empty areas
' Insert - Determines state of insert (on/off)
' Default$ - Text that is already in the textbox
' Mask$ - Determines the mask string
' Usage of mask:
' You may put any character or number in this string.
' To set where numbers are to be put, insert a "#".
' To set where all others are to be put, insert a "$".
' If you want to put in a "$" to be printed, insert a "~"
' example: "~###.##" would turn to "$###.##"
' Flags - Defines the following flags:
' qbSetUp - Used to put the textbox before it is
' accessed.
' qbShowMask - For showing entire mask
' qbForceComplete - Force the user to finish the mask.
' Req$ - These character(s) are required in the string.
'
'
DECLARE FUNCTION GetInput$ (Row&, Col&, PasswordChar$, MaxWidth&, Fore&, Back&, Empty$, Insert&, Default$, Mask$, Flags&, Req$)
DECLARE SUB PrintHelp (text$)
CONST CURRENTFORE = -1, CURRENTBACK = -2
CONST qbSetUp = 2, qbShowMask = 8, qbForceComplete = 256
CLS
COLOR 15, 0
PRINT " GetInput$ Demonstration Program:"
PRINT " Form Application "
PRINT
LOCATE 5, 1: PRINT "Press any key to begin";
DO UNTIL I$ <> "": I$ = INKEY$: LOOP
LOCATE 5, 1: PRINT " "
'Name$ = GetInput$(1, 1, "", 40, CURRENTFORE, CURRENTBACK, "ù", 0, "", "Price: ~####.##", qbSetUp + qbForceComplete)
LOCATE 4, 1: PRINT "Name:"
PrintHelp "This is a simple, basic GetInput$ structure."
Name$ = GetInput$(4, 20, "", 40, 15, 1, "ù", 0, "", "", 0, "")
COLOR 15, 0
LOCATE 5, 1: PRINT "Street Address:"
PrintHelp "This, too, has a simple structure."
Street$ = GetInput$(5, 20, "", 50, 15, 1, "ù", 0, "", "", 0, "")
COLOR 15, 0
LOCATE 6, 1: PRINT "City:"
PrintHelp "This is a simple text box."
Name$ = GetInput$(6, 20, "", 50, 15, 1, "ù", 0, "", "", 0, "")
COLOR 15, 0
LOCATE 7, 1: PRINT "State:"
PrintHelp "This has a mask. Enter the 2-character abbreviation."
City$ = GetInput$(7, 20, "", 2, 15, 1, "ù", 0, "", "$$", 0, "")
COLOR 15, 0
LOCATE 7, 30: PRINT "Zip Code:"
PrintHelp "This has a number mask. Enter the 5-digit code."
ZipCode$ = GetInput$(7, 41, "", 5, 15, 1, "ù", 0, "", "#####", 0, "")
COLOR 15, 0
LOCATE 8, 1: PRINT "Phone Number:"
PrintHelp "This has custom mask. You have to finish the number."
Phone$ = GetInput$(8, 20, "", 14, 15, 1, "ù", 0, "", "(###) ###-####", qbForceComplete, "")
COLOR 15, 0
LOCATE 9, 1: PRINT "Fax Number:"
PrintHelp "This has custom mask. You don't have to finish the number."
Fax$ = GetInput$(9, 20, "", 14, 15, 1, "ù", 0, "", "(###) ###-####", 0, "")
COLOR 15, 0
LOCATE 10, 1: PRINT "Email:"
PrintHelp "This requires you to type in a '@' and '.'"
Email$ = GetInput$(10, 20, "", 40, 15, 1, "ù", 0, "", "", 0, "@.")
COLOR 15, 0
LOCATE 11, 1: PRINT "Password:"
PrintHelp "This is hidden to the user."
Password$ = GetInput$(11, 20, "*", 20, 15, 1, "ù", 0, "", "", 0, "")
COLOR 15, 0
LOCATE 12, 1: PRINT "Fake Social Security Number:"
PrintHelp "This has a password mask."
SocialSecurity$ = GetInput$(12, 30, "*", 11, 15, 1, "ù", 0, "", "###-##-####", 0, "")
COLOR 15, 0
CLS
PRINT " GetInput$ Demonstration Program: "
PRINT " Form Application "
PRINT " "
PRINT " "
PRINT " There is a variety of things you can do"
PRINT " with this function. You can change the"
PRINT " password character and the character"
PRINT " that is printed in the empty space. See"
PRINT " the instruction comments in the program"
PRINT " or the readme file included with this."
END
DEFLNG A-Z
'Define all unsigned variables to be LONG
FUNCTION GetInput$ (Row, Col, PasswordChar$, MaxWidth, Fore, Back, Empty$, Insert, Default$, Mask$, Flags, Req$)
SELECT CASE Flags
CASE qbSetUp: SetUp = -1
CASE qbShowMask: ShowMask = -1
CASE qbForceComplete: Force = -1
CASE qbSetUp + qbShowMask: SetUp = -1: ShowMask = -1
CASE qbSetUp + qbForceComplete: SetUp = -1: Force = -1
CASE qbShowMask + qbForceComplete: ShowMask = -1: Force = -1
CASE qbSetUp + qbShowMask + qbForceComplete: SetUp = -1: ShowMask = -1: Force = -1
END SELECT
' Print text for foreground and background saves
LOCATE Row, Col: PRINT "A"
GetForeColor = SCREEN(Row, Col, 1) MOD 16 'Save foreground color
GetBackColor = SCREEN(Row, Col, 1) / 16 'Save background color
Mask = 0
IF Mask$ <> "" THEN
Mask = -1
MaxWidth = LEN(Mask$)
FOR CountLen = 1 TO LEN(Mask$)
a$ = MID$(Mask$, CountLen, 1)
IF a$ = "#" OR a$ = "$" THEN
Ms$ = Ms$ + a$
MaskCount = MaskCount + 1
END IF
NEXT
END IF
IF Empty$ = "" THEN Empty$ = " "
text$ = Default$
CurrentPos = LEN(text$) + 1
GOSUB PutText 'Put text on screen
IF SetUp THEN EXIT FUNCTION
DO
I$ = INKEY$ 'Get keyboard character
SELECT CASE I$
CASE CHR$(8) 'Backspace
IF LEN(text$) > 0 THEN
text$ = MID$(text$, 1, CurrentPos - 2) + MID$(text$, CurrentPos, LEN(text$))
CurrentPos = CurrentPos - 1
END IF
CASE CHR$(27) 'Escape
IF Force AND LEN(text$) < MaskCount THEN
ELSE
IsThere = 0
FOR CheckReq = 1 TO LEN(Req$)
a$ = MID$(Req$, CheckReq, 1)
IF INSTR(1, text$, a$) = 0 THEN
IsThere = -1
END IF
NEXT
IF NOT IsThere THEN
EXIT FUNCTION
END IF
END IF
CASE CHR$(13) 'Enter
IF Force AND LEN(text$) < MaskCount THEN
ELSE
IsThere = 0
FOR CheckReq = 1 TO LEN(Req$)
a$ = MID$(Req$, CheckReq, 1)
IF INSTR(1, text$, a$) = 0 THEN
IsThere = -1
END IF
NEXT
IF NOT IsThere THEN
EXIT DO
END IF
END IF
CASE CHR$(0) + "M" 'Right
IF Mask = 0 THEN
IF CurrentPos < LEN(text$) + 1 THEN
CurrentPos = CurrentPos + 1
END IF
END IF
CASE CHR$(0) + "K" 'Left
IF Mask = 0 THEN
IF CurrentPos > 1 THEN
CurrentPos = CurrentPos - 1
END IF
END IF
CASE ELSE 'Anything else
IF Mask = 0 THEN
IF LEN(I$) = 1 AND LEN(text$) < MaxWidth THEN
IfInsCurrent = CurrentPos
IF Insert = 1 THEN IfInsCurrent = CurrentPos + 1
text$ = MID$(text$, 1, CurrentPos - 1) + I$ + MID$(text$, IfInsCurrent, LEN(text$))
CurrentPos = CurrentPos + 1
END IF
ELSE
IF LEN(I$) = 1 AND LEN(text$) < MaskCount THEN
IF MID$(Ms$, LEN(text$) + 1, 1) = "#" THEN
IF VAL(I$) > 0 OR I$ = "0" THEN
text$ = text$ + I$
CurrentPos = CurrentPos + 1
END IF
ELSEIF MID$(Ms$, LEN(text$) + 1, 1) = "$" THEN
text$ = text$ + I$
CurrentPos = CurrentPos + 1
END IF
END IF
END IF
END SELECT
SkipIt:
IF I$ <> "" THEN GOSUB PutText
LOOP
' Set the text to be returned
GetInput$ = text$
' Restore previous colors
COLOR GetForeColor, GetBackColor
LOCATE , , 0, 10, 11
EXIT FUNCTION
PutText:
IF Fore <> CURRENTFORE THEN
COLOR Fore
ELSE
COLOR GetForeColor
END IF
IF Back <> CURRENTBACK THEN
COLOR , Back
ELSE
COLOR , GetBackColor
END IF
' Put the character for empty spaces
LOCATE Row, Col + LEN(text$), 0: PRINT STRING$(MaxWidth - LEN(text$), Empty$);
' Print the text on the screen
IF Mask = 0 THEN
IF PasswordChar$ = "" THEN
LOCATE Row, Col, 0: PRINT text$;
IF Insert = 0 THEN
LOCATE Row, Col + CurrentPos - 1, 1, 10, 11: PRINT ;
ELSE
LOCATE Row, Col + CurrentPos - 1, 1, 1, 11: PRINT ;
END IF
ELSE
LOCATE Row, Col, 0: PRINT STRING$(LEN(text$), PasswordChar$);
IF Insert = 0 THEN
LOCATE Row, Col + CurrentPos - 1, 1, 10, 11: PRINT ;
ELSE
LOCATE Row, Col + CurrentPos - 1, 1, 1, 11: PRINT ;
END IF
END IF
ELSE
IF PasswordChar$ = "" THEN
Txt$ = Mask$
B = 0
AlR = 0
FOR FillText = 1 TO LEN(Mask$)
a$ = MID$(Mask$, FillText, 1)
IF a$ = "$" OR a$ = "#" THEN
B = B + 1
IF B = LEN(text$) AND AlR = 0 THEN AlR = 1: NTxt = FillText
MID$(Txt$, FillText, 1) = MID$(text$, B, 1)
END IF
NEXT
IF LEN(text$) = 0 THEN NTxt = 0
FOR fillChar = 1 TO LEN(Txt$)
IF MID$(Txt$, fillChar, 1) = "~" THEN
MID$(Txt$, fillChar, 1) = "$"
END IF
NEXT
IF NOT ShowMask THEN Txt$ = MID$(Txt$, 1, NTxt)
LOCATE Row, Col, 0: PRINT Txt$;
IF Insert = 0 THEN
LOCATE Row, Col + NTxt, 1, 10, 11: PRINT ;
ELSE
LOCATE Row, Col + NTxt, 1, 1, 11: PRINT ;
END IF
ELSE
Txt$ = Mask$
B = 0
AlR = 0
FOR FillText = 1 TO LEN(Mask$)
a$ = MID$(Mask$, FillText, 1)
IF a$ = "$" OR a$ = "#" THEN
B = B + 1
IF B = LEN(text$) AND AlR = 0 THEN AlR = 1: NTxt = FillText
MID$(Txt$, FillText, 1) = PasswordChar$
END IF
NEXT
IF LEN(text$) = 0 THEN NTxt = 0
FOR fillChar = 1 TO LEN(Txt$)
IF MID$(Txt$, fillChar, 1) = "~" THEN
MID$(Txt$, fillChar, 1) = "$"
END IF
NEXT
IF NOT ShowMask THEN Txt$ = MID$(Txt$, 1, NTxt)
LOCATE Row, Col, 0: PRINT Txt$;
IF Insert = 0 THEN
LOCATE Row, Col + NTxt, 1, 10, 11: PRINT ;
ELSE
LOCATE Row, Col + NTxt, 1, 1, 11: PRINT ;
END IF
END IF
END IF
RETURN
END FUNCTION
DEFSNG A-Z
SUB PrintHelp (text$)
Txt$ = SPACE$(80)
MID$(Txt$, 41 - LEN(text$) / 2) = text$
COLOR 14, 1
LOCATE 25, 1: PRINT Txt$;
END S
************ Eingabe Maske mit Len Funktion in Qbasic *************
' This program allows you to get string input in controlled fields
' that you can travel forward and backwards through with all editing
' capabilities. This is especially useful for editing records in a database
'
' * with slight modification you could add support for numeric fields &
' preloading the fields with values
'
'
' Feel free to integrate this program into yours - enjoy!
'
' ***************************************************************************
' Look for our awesome tetris variation matrix.zip written completly in QB4.5
' ***************************************************************************
'
' you can contact us via:
' AOL - DPast19685
' Compuserve - 74734,2203
'
' Nocturnal Creations
' P.O. Box 913
' Springfield, MA 01151
'
'****************************************************************************
DECLARE SUB editor (x%(), y%(), fl%(), text$(), max%)
DECLARE SUB PaintScr ()
max% = 8 ' define max number of
' fields
DIM x%(max%), y%(max%), fl%(max%), text$(max%) ' dimension arrays
FOR n% = 1 TO max%
READ a%, b%, c% ' read in x,y cordin
x%(n%) = a% ' & field lenths
y%(n%) = b%
fl%(n%) = c%
NEXT n%
CALL PaintScr ' draw screen
CALL editor(x%(), y%(), fl%(), text$(), max%) ' call editor
' ************* unrem this to see text strings after editor *************
'
' LOCATE 23, 6: PRINT " Press any key . . . "
' WHILE INKEY$ = "": WEND
' CLS
'
' FOR n% = 1 TO max%
' PRINT "Text string "; n%; " "; text$(n%)
' NEXT n%
'
' ************************************************************************
' x, y, fl define x & y cordinates and the field lenths here
'
DATA 21,16,10
DATA 21,17,30
DATA 21,18,30
DATA 21,19,27
DATA 56,19,4
DATA 67,19,10
DATA 21,20,16
DATA 21,21,50
SUB editor (x%(), y%(), fl%(), text$(), max%)
DIM curserpos%(max%) ' to hold field cursor pos's
DIM char(60, max%) AS STRING * 1 ' to hold field cells
FOR z% = 1 TO max% ' fill all field cells
FOR x% = 1 TO fl%(z%) ' with blank spaces
char(x%, z%) = CHR$(32)
NEXT x%
NEXT z%
FOR n% = 1 TO max% ' set the default cursor
curserpos%(n%) = 1 ' position to equal 1 in
NEXT n% ' in all fields
uc% = 1 ' upper case flag for proper F3
e% = 1 ' set starting field to 1
done% = 0 ' not done yet!!
insert% = 0 ' insert on ( default )
COLOR 0, 7 ' init first field
LOCATE y%(e%), x%(e%): PRINT STRING$(fl%(e%), 32) '
LOCATE y%(e%), x%(e%), 1 '
DO ' loop until user presses
' escape
DO
i$ = INKEY$ ' wait for a keypress
LOOP WHILE i$ = ""
IF LEN(i$) = 1 THEN ' create key code
i% = ASC(i$) ' regular key
ELSE
i% = -ASC(RIGHT$(i$, 1)) ' extented key
END IF
SELECT CASE i% ' process key
CASE 8 ' **** backspace ****
IF curserpos%(e%) > 1 THEN ' if not first cell in
' field
FOR n% = curserpos%(e%) TO fl%(e%)
char(n% - 1, e%) = char(n%, e%) ' drag everything starting
char(n%, e%) = " " ' at cursor pos back 1 cell
NEXT n%
curserpos%(e%) = curserpos%(e%) - 1 ' dec cursor pos
END IF
CASE 27 ' **** escape key ****
text$(e%) = "" ' set current $ to null
FOR n% = 1 TO fl%(e%) ' rebuild string from
' cells
IF char(n%, e%) = "" THEN char(n%, e%) = " "
text$(e%) = text$(e%) + char(n%, e%)
NEXT n%
COLOR 7, 9 ' reprint string
LOCATE y%(e%), x%(e%), 0: PRINT text$(e%) '
done% = 1 ' all done
CASE 32 TO 126 ' **** letter keys ****
IF insert% = 0 THEN ' if insert mode
IF curserpos%(e%) <= fl%(e%) THEN ' if not end of field
FOR n% = fl%(e%) TO curserpos%(e%) STEP -1 ' bring cells in
char(n% + 1, e%) = char(n%, e%) ' front of cursor
NEXT n% ' ahead 1
char(curserpos%(e%), e%) = i$ ' make cell at cursor
' pos = input
IF curserpos%(e%) < fl%(e%) THEN ' if not end of field
curserpos%(e%) = curserpos%(e%) + 1 ' inc cursor pos
END IF
END IF
ELSE ' if not insert mode
IF curserpos%(e%) <= fl%(e%) THEN ' if not end of field
char(curserpos%(e%), e%) = i$ ' make cursor pos cell
' = input
IF curserpos%(e%) < fl%(e%) THEN ' if not end of field
curserpos%(e%) = curserpos%(e%) + 1 ' inc cursor pos
END IF
END IF
END IF
CASE -59 ' **** F1 ****
FOR n% = 1 TO fl%(e%) ' loop though cells
char(n%, e%) = LCASE$(char(n%, e%)) ' & make them lower
NEXT n% ' case
CASE -60 ' **** F2 ****
FOR n% = 1 TO fl%(e%) ' loop though cells
char(n%, e%) = UCASE$(char(n%, e%)) ' & make them upper
NEXT n% ' case
CASE -61 ' **** F3 ****
FOR n% = 0 TO fl%(e%) ' loop though entire
' field
IF char(n%, e%) >= "A" AND char(n%, e%) <= "z" THEN ' if A-z
IF uc% THEN ' if upper case flag on
char(n%, e%) = UCASE$(char(n%, e%)) ' make cell upper case
uc% = 0 ' set flag off
ELSE ' if flag is off
char(n%, e%) = LCASE$(char(n%, e%)) ' make cell lower
END IF ' case
END IF
IF char(n%, e%) = " " OR char(n%, e%) = "" THEN ' if cell =
uc% = 1 ' a space turn flag on
END IF
NEXT n%
CASE -71 ' **** home ****
curserpos%(e%) = 1 ' set cursor pos to
' begining
CASE -72 ' **** up ****
IF e% > 1 THEN ' if not first field
dir% = 0 ' direction = -
GOSUB switch ' switch field
END IF
CASE -75 ' **** left ****
IF curserpos%(e%) > 1 THEN ' if not begining of field
curserpos%(e%) = curserpos%(e%) - 1 ' dec cursor pos
ELSE ' if begining of field
IF e% > 1 THEN ' if not first field
dir% = 0 ' direction = -
curserpos%(e% - 1) = fl%(e% - 1) ' set last cursor pos to
GOSUB switch ' end of last field
END IF
END IF
CASE -77 ' **** right ****
IF curserpos%(e%) < fl%(e%) THEN ' if not end of field
curserpos%(e%) = curserpos%(e%) + 1 ' inc cursor pos
ELSE ' if end of field
IF e% < max% THEN ' if not last field
dir% = 1 ' direction = +
curserpos%(e% + 1) = 1 ' set next cursor pos to
GOSUB switch ' beginning of next field
END IF
END IF
CASE -79 ' **** end ****
n% = fl%(e%) ' set counter to fl
DO
IF char(n%, e%) <> CHR$(32) THEN ' if cell does not = a
curserpos%(e%) = n% + 1 ' space we've found end
EXIT DO ' of text - exit loop
END IF
n% = n% - 1 ' dec n
LOOP UNTIL n% = 1 ' until begining of field
CASE -80 ' **** down ****
IF e% < max% THEN ' if not in last field
dir% = 1 ' direction = +
GOSUB switch ' switch field
END IF
CASE -82 ' **** insert ****
IF insert% = 0 THEN ' if insert on
insert% = 1 ' turn it off & set
LOCATE y%(e%), (x%(e%) + curserpos%(e%)), 1, 0, 7 ' cursor
' style
ELSE ' if insert off
insert% = 0 ' turn it on & set
LOCATE y%(e%), (x%(e%) + curserpos%(e%)), 1, 7, 7 ' cursor
' style
END IF
CASE -83 ' **** del ****
FOR n% = curserpos%(e%) TO fl%(e%) ' drag all cells from
char(n%, e%) = char(n% + 1, e%) ' cursor pos to end
NEXT n% ' back one
CASE 13 ' **** enter ****
IF e% < max% THEN ' if not last field
dir% = 1 ' direction = +
GOSUB switch ' switch field
END IF
END SELECT
text$(e%) = "" ' set text$ to null
char(fl%(e%) + 1, e%) = " "
FOR n% = 1 TO fl%(e%) ' rebuild text$ from
text$(e%) = text$(e%) + char(n%, e%) ' cells
NEXT n%
LOCATE y%(e%), x%(e%), 1: PRINT text$(e%) ' display field
LOCATE y%(e%), (curserpos%(e%) - 1 + x%(e%)), 1
LOOP UNTIL done% ' until escape
EXIT SUB
switch:
text$(e%) = "" ' set current text$
' to null
FOR n% = 1 TO fl%(e%)
IF char(n%, e%) = "" THEN char(n%, e%) = " " ' rebuild string
text$(e%) = text$(e%) + char(n%, e%) ' from cells
NEXT n%
COLOR 7, 9: LOCATE y%(e%), x%(e%), 0: PRINT text$(e%) ' display
' string
IF dir% = 1 THEN ' + direction
e% = e% + 1 ' inc e
ELSE ' - direction
e% = e% - 1 ' dec e
END IF
COLOR 0, 7 ' display next/
LOCATE y%(e%), x%(e%): PRINT STRING$(fl%(e%), 32) ' last field
LOCATE y%(e%), curserpos%(e%) + x%(e%), 1 '
RETURN
END SUB
SUB PaintScr
COLOR 7, 9
CLS
FOR n% = 3 TO 77
LOCATE 4, n%: PRINT CHR$(196)
LOCATE 14, n%: PRINT CHR$(196)
LOCATE 23, n%: PRINT CHR$(196)
NEXT n%
LOCATE 2, 7: PRINT "Input Field Example"
LOCATE 3, 7: PRINT "1992 Nocturnal Creations - David Pastore, Timothy Truman"
LOCATE 5, 7: PRINT "Keys: up,down,left,right - to scroll cursor though fields"
LOCATE 6, 15: PRINT "insert - toggle insert mode"
LOCATE 7, 15: PRINT "delete - delete char at cursor"
LOCATE 8, 15: PRINT "home - go to begining of field"
LOCATE 9, 15: PRINT "end - go to end of text"
LOCATE 10, 15: PRINT "F1 - convert field to lower case"
LOCATE 11, 15: PRINT "F2 - convert field to upper case"
LOCATE 12, 15: PRINT "F3 - convert field to proper case"
LOCATE 13, 15: PRINT "Esc - quits"
LOCATE 16, 10: PRINT "Account #:"
LOCATE 17, 10: PRINT "Name :"
LOCATE 18, 10: PRINT "Address :"
LOCATE 19, 10: PRINT "City : State: Zip:"
LOCATE 20, 10: PRINT "Phone :"
LOCATE 21, 10: PRINT "Comment :"
END SUBGruss Mik
Code-Tags ergänzt - Kaeru fecit
