'=========================================================================== ' Subject: INPUT ROUTINES Date: 10/93 (00:00) ' Author: Bert Christensen Code: QB, QBasic, PDS ' Origin: PC Resources Packet: TEXT.ABC '=========================================================================== ' ' ROSEWOOD QUICKBASIC STUFF v 1 consists of two programs which can be ' incorporated into programs written in QuickBasic 4.xx or QBasic which ' is supplied with MS DOS 5 and 6. Libraries or commands such as ' CALL INTERRUPT not used in QBasic are not needed with this code. ' ' There are two distinct parts of the program: ' ' The first is an input editor which will replace the commands "INPUT", ' "LINE INPUT", etc. with an input routine written with INKEY$ as the input. ' INKEY$ allows much nicer inputting, especially if you have several inputs ' to process in succession. This editor can be set up to accept various types ' of input and to block other types. This will greatly reduce the amount of ' error checking which is associated with the usual input functions. ' Some parts of this program may look ancient with its IF..ENDs and GOTOs. ' However, I like to have the ability to cascade through the editor. See ' how scan% = 8 becomes scan% = 83 in the backspace command area. The program ' could be written using only DO..LOOP, SELECT CASE etc. but I doubt that it ' would make the program work better. It would be prettier though. ' The editor is very loosely based on a program from the magazine, ' PC RESOURCES, October 1987, pg. 61 ' ' The second part of the code is a simple window program. Windows of any ' size or colour, with or without a border, can be placed anywhere on the ' screen with text justified left, centre and right, and then wiped off so ' that the original screen below is restored. The speed in drawing and ' erasing these windows is not as great as windows using registers and ' CALL ABSOLUTE, but it is adequate for most purposes. ' This code is written by: Bert Christensen ' Rosewood Software ' 135-10 Livonia Place ' Scarborough, Ontario, Canada M1E 4W6 ' (416) 284-6119, CompuServe 70461,2507 ' Internet bert.christensen@canrem.com ' ' Copyright (c) 1993 by Bert Christensen ' ' Anyone is granted full permission to use all or part of this program ' without charge. However, if you should feel moved to send a donation, ' it will not be refused. ' ' Any comments would be appreciated. ' ' ' ROSEWOOD QUICKBASIC STUFF v 1 ' ' Programmed in MicroSoft QuickBasic 4.5 and VisualBasic for DOS 1.00 ' October 1993 ' ' ' ******DECLARATIONS***** DECLARE SUB Fulledit (row%(), column%(), numentry%, inperr%(), item$(), itemlen%(), itemflag%()) DECLARE SUB WindowSub (wintop%, winbot%, winleft%, winright%, winforecolour%, winbackcolour%, wintext$(), winborder%) DECLARE FUNCTION Justify$ (text$, just%, winleft%, winright%) DECLARE SUB Frame (toprow%, bottomrow%, leftcol%, rightcol%) COMMON SHARED /colours/ sfg%, sbg%, rfg%, rbg%, ffg%, fbg% sfg% = 0 'standard foreground sbg% = 7 'standard background rfg% = 7 'reverse foreground rbg% = 1 'reverse background REM ffg% = frame foreground REM fbg% = frame background REM ******************EDITOR SECTION********************** LOCATE 1, 1 'goto top left so whole screen will be "coloured" COLOR sfg%, sbg% CLS COLOR rfg%, rbg% ' place prompts on the screen LOCATE 1, 12: PRINT "`Rosewood QB Stuff' Input Editor for QuickBasic & QBasic" COLOR sfg%, sbg% LOCATE 3, 5: PRINT "This field accepts 0 to 9 & space only"; : LOCATE 5, 5: PRINT "This field accepts all alphanumeric entries"; LOCATE 7, 5: PRINT "This field accepts `0' to `9',`-', `.' and `space' only"; : LOCATE 9, 5: PRINT "The Esc key is disabled in this field"; LOCATE 11, 5: PRINT "Edit pre-existing data"; : LOCATE 13, 5: PRINT "Field length of 1"; : LOCATE 15, 5: PRINT "Field length of 45"; LOCATE 17, 27: PRINT "Fields can be placed anywhere on screen" LOCATE 19, 1: PRINT STRING$(80, "*"); LOCATE 20, 5: PRINT "Use arrow keys, Home, End, PgUp, PgDn, Del, Bksp, Ins to edit"; LOCATE 21, 5: PRINT "Ctrl F3 to delete input; Ctrl F4 to copy text; Ctrl F5 to paste"; LOCATE 22, 5: PRINT "Ctrl End & Ctrl Home to move to ends of field; Ctrl F10 to quit editing"; LOCATE 23, 5: PRINT "Ctrl F6 to centre text"; entryload$ = "Bert Christensen, Rosewood Software" 'see item$(5) below numentry% = 8 'number of input items. can be 1 to ?? REDIM item$(numentry%), itemlen%(numentry%), inperr%(numentry%), row%(numentry%), column%(numentry%), itemflag%(numentry%) 'item$() = the input item. if there is data to be edited, see below at item$(5). 'if there is no data to be edited then item$() = " ". 'itemlen%() = the length of the item$(). 'inperr%() is a flag to manipulate data in the sub, Fulledit 'column%() is the horizontal column position to start the editing of the particular item$() 'row%() is the vertical row to start editing the item$() 'itemflag%() is like inperr%() above (in case you should need 2) 'below is the filling of the arrray item$(1) = " ": itemlen%(1) = 5: inperr%(1) = 0: column%(1) = 44: row%(1) = 3: itemflag%(1) = 1 item$(2) = " ": itemlen%(2) = 25: inperr%(2) = 0: column%(2) = 50: row%(2) = 5: itemflag%(2) = 0 item$(3) = " ": itemlen%(3) = 10: inperr%(3) = 0: column%(3) = 64: row%(3) = 7: itemflag%(3) = 2 item$(4) = " ": itemlen%(4) = 6: inperr%(4) = 1: column%(4) = 45: row%(4) = 9: itemflag%(4) = 0 'inperr% = 1 item$(5) = entryload$: itemlen%(5) = 40: inperr%(5) = 0: column%(5) = 30: row%(5) = 11: itemflag%(5) = 0 item$(6) = " ": itemlen%(6) = 1: inperr%(6) = 0: column%(6) = 25: row%(6) = 13: itemflag%(6) = 0 item$(7) = " ": itemlen%(7) = 45: inperr%(7) = 0: column%(7) = 24: row%(7) = 15: itemflag%(7) = 0 item$(8) = " ": itemlen%(8) = 20: inperr%(8) = 0: column%(8) = 5: row%(8) = 17: itemflag%(8) = 0 CALL Fulledit(row%(), column%(), numentry%, inperr%(), item$(), itemlen%(), itemflag%()) CLS REM *****************BACKGROUND PATTERN SECTION***************** FOR row% = 1 TO 25 FOR column% = 1 TO 80 LOCATE row%, column% COLOR sfg%, sbg% PRINT CHR$(177); 'fill screen with background pattern NEXT column% NEXT row% REM ****************WINDOWS SECTION****************** wintop% = 8 'initialize placement of window winbot% = 21 ' " " " " winleft% = 10 ' " " " " winright% = 70 ' " " " " DIM wintext$(winbot% - wintop% + 1) 'dimension array for lines of text REM wintext$(1) is a null string because the frame will cover it wintext$(2) = Justify$("Results returned by Rosewood QB Stuff Input Editor", 2, winleft%, winright%) wintext$(4) = "item$(1) = " + item$(1) wintext$(5) = "item$(2) = " + item$(2) wintext$(6) = "item$(3) = " + item$(3) wintext$(7) = "item$(4) = " + item$(4) wintext$(8) = Justify$("item$(5) = " + item$(5), 1, winleft%, winright%) 'see justify$ function wintext$(9) = Justify$("item$(6) = " + item$(6), 0, winleft%, winright%) wintext$(10) = "item$(7) = " + item$(7) wintext$(11) = Justify$("item$(8) = " + item$(8), 0, winleft%, winright%) wintext$(12) = "" wintext$(13) = Justify$("Press any key to continue...", 2, winleft%, winright%) CALL WindowSub(wintop%, winbot%, winleft%, winright%, 15, 4, wintext$(), 1) REM ***********SECOND WINDOW********** wintop% = 10 winbot% = 22 winleft% = 10 winright% = 40 REDIM wintext$(winbot% - wintop% + 1) FOR x% = 2 TO 6 wintext$(x%) = Justify$("Right Justified", 3, winleft%, winright%) NEXT x% CALL WindowSub(wintop%, winbot%, winleft%, winright%, 15, 3, wintext$(), 0) REM **********THIRD WINDOW********** wintop% = 6 winbot% = 11 winleft% = 4 winright% = 40 REDIM wintext$(winbot% - wintop% + 1) FOR x% = 2 TO 6 wintext$(x%) = Justify$("Centered Text", 2, winleft%, winright%) NEXT x% CALL WindowSub(wintop%, winbot%, winleft%, winright%, 15, 6, wintext$(), 1) REM *********FOURTH WINDOW*********** wintop% = 13 winbot% = 23 winleft% = 10 winright% = 70 REDIM wintext$(winbot% - wintop% + 1) wintext$(2) = Justify$("ROSEWOOD QUICKBASIC STUFF is brought to you by:", 2, winleft%, winright%) wintext$(3) = Justify$("Bert Christensen", 2, winleft%, winright%) wintext$(4) = Justify$("Rosewood Software", 2, winleft%, winright%) wintext$(5) = Justify$("135-10 Livonia Place", 2, winleft%, winright%) wintext$(6) = Justify$("Scarborough, Ontario M1E 4W6 Canada", 2, winleft%, winright%) wintext$(7) = Justify$("Telephone (416) 284-6119", 2, winleft%, winright%) wintext$(8) = Justify$("CompuServe 70461,2507 Internet bert.christensen@canrem.com", 2, winleft%, winright%) wintext$(10) = Justify$("Copyright (c) 1993", 2, winleft%, winright%) CALL WindowSub(wintop%, winbot%, winleft%, winright%, 15, 5, wintext$(), 1) COLOR sfg%, sbg% END SUB Frame (toprow%, bottomrow%, leftcol%, rightcol%) LOCATE toprow%, leftcol%: COLOR ffg%, fbg%: PRINT CHR$(201) 'top left corner LOCATE toprow%, rightcol%: COLOR ffg%, fbg%: PRINT CHR$(187) 'top right corner LOCATE bottomrow%, leftcol%: COLOR ffg%, fbg%: COLOR ffg%, fbg%: PRINT CHR$(200); 'bottom left corner LOCATE bottomrow%, rightcol%: COLOR ffg%, fbg%: PRINT CHR$(188); 'bottom right corner FOR vertline% = toprow% + 1 TO bottomrow% - 1 'vertical lines LOCATE vertline%, leftcol%: COLOR ffg%, fbg%: PRINT CHR$(186); LOCATE vertline%, rightcol%: COLOR ffg%, fbg%: PRINT CHR$(186); NEXT vertline% horizlength% = rightcol% - leftcol% - 1 'horizontal lines horizline$ = STRING$(horizlength%, 205) LOCATE toprow%, leftcol% + 1: COLOR ffg%, fbg%: PRINT horizline$ LOCATE bottomrow%, leftcol% + 1: COLOR ffg%, fbg%: PRINT horizline$; LOCATE , , 0 END SUB SUB Fulledit (row%(), column%(), numentry%, inperr%(), item$(), itemlen%(), itemflag%()) 'there are some Wordstar type commands "scan% = 19 is Ctrl S". I hate Wordstar so I never completed all the commands. LOCATE , , 0 insertkey% = 0 'make typeover the default sc1% = 6 'cursor size for default typeover sc2% = 7 FOR menuitem% = 1 TO numentry% 'make sure that existing entries have proper length IF LEN(item$(menuitem%)) < itemlen%(menuitem%) THEN item$(menuitem%) = item$(menuitem%) + STRING$((itemlen%(menuitem%) - LEN(item$(menuitem%))), " ") 'pad with spaces ELSEIF LEN(item$(menuitem%)) > itemlen%(menuitem%) THEN item$(menuitem%) = LEFT$(item$(menuitem%), itemlen%(menuitem%)) 'truncate if necessary END IF NEXT menuitem% itemnum% = 1 'start a first input entry FOR entry% = 1 TO numentry% 'enter default data and/or spaces in proper places colm% = column%(entry%) FOR leng% = 1 TO itemlen%(entry%) COLOR rfg%, rbg% LOCATE row%(entry%), colm% defaultstr$ = MID$(item$(entry%), leng%, 1) PRINT defaultstr$; colm% = colm% + 1 NEXT leng% NEXT entry% printcolumn% = column%(itemnum%) 'start at leftmost column ed1: COLOR rfg%, rbg%: LOCATE row%(itemnum%), printcolumn%, 1, sc1%, sc2% 'Place the cursor ed2: keypress$ = "": keypress$ = INKEY$: IF keypress$ = "" THEN GOTO ed2 'wait for keypress scan% = ASC(keypress$) 'change keypress to integer ed4: IF scan% = 27 THEN 'Esc IF inperr%(itemnum%) = 1 THEN ' to prevent user from escaping from sub BEEP ELSE EXIT SUB END IF END IF IF scan% > 31 AND scan% < 127 THEN 'Alphanum chars only DO SELECT CASE itemflag%(itemnum%) 'determine which set of characters are acceptable CASE 0 'any alpha numeric CASE 1 ' 0 to 9 and space SELECT CASE scan% CASE 32, 48 TO 57 ' nothing to do. Let if "fall through" the SELECT CASE CASE ELSE BEEP GOTO ed2 END SELECT CASE 2 '0 to 9, -,., space SELECT CASE scan% CASE 32, 45, 46, 48 TO 57 CASE ELSE BEEP GOTO ed2 END SELECT END SELECT IF insertkey% = 0 THEN 'typeover MID$(item$(itemnum%), printcolumn% - column%(itemnum%) + 1, 1) = keypress$ PRINT keypress$; ELSE item$(itemnum%) = LEFT$(LEFT$(item$(itemnum%), printcolumn% - column%(itemnum%)) + CHR$(scan%) + MID$(item$(itemnum%), printcolumn% - column%(itemnum%) + 1, column%(itemnum%)), itemlen%(itemnum%)) 'insert LOCATE row%(itemnum%), column%(itemnum%), 1, sc1%, sc2% item$(itemnum%) = LEFT$(item$(itemnum%), itemlen%(itemnum%)) PRINT item$(itemnum%); END IF scan% = 77 'move right 1 space EXIT DO LOOP END IF IF scan% = 8 AND printcolumn% > column%(itemnum%) THEN 'Back Space printcolumn% = printcolumn% - 1 LOCATE row%(itemnum%), printcolumn%, 1, sc1%, sc2% scan% = 83 END IF IF scan% = 0 THEN scan% = ASC(RIGHT$(keypress$, 1)) 'Extended character ' scan% = 4 is the Wordstar Ctrl D IF (scan% = 77 OR scan% = 4) AND printcolumn% < column%(itemnum%) - 1 + itemlen%(itemnum%) THEN 'Right arrow printcolumn% = printcolumn% + 1 GOTO ed1 END IF '19 = Ctrl S IF (scan% = 75 OR scan% = 19) AND printcolumn% > column%(itemnum%) THEN 'Left arrow printcolumn% = printcolumn% - 1 GOTO ed1 END IF IF scan% = 79 THEN 'end for End of text IF LEN(RTRIM$(item$(itemnum%))) = 0 THEN printcolumn% = column%(itemnum%) + itemlen%(itemnum%) - 1 ELSE printcolumn% = column%(itemnum%) + LEN(RTRIM$(item$(itemnum%))) IF printcolumn% > column%(itemnum%) + itemlen%(itemnum%) - 1 THEN printcolumn% = column%(itemnum%) + itemlen%(itemnum%) - 1 END IF GOTO ed1 END IF IF scan% = 99 THEN 'centre text on line lenitm% = LEN(LTRIM$(RTRIM$(item$(itemnum%)))) item$(itemnum%) = SPACE$((itemlen%(itemnum%) - lenitm%) \ 2) + LTRIM$(RTRIM$(item$(itemnum%))) item$(itemnum%) = item$(itemnum%) + SPACE$(itemlen%(itemnum%) - LEN(item$(itemnum%))) LOCATE row%(itemnum%), column%(itemnum%), 1, sc1%, sc2% PRINT item$(itemnum%); scan% = 80 END IF IF scan% = 117 THEN 'ctrl + end to go to end of line printcolumn% = column%(itemnum%) + itemlen%(itemnum%) - 1 GOTO ed1 END IF IF scan% = 71 THEN ' Home to beginning of text IF LEN(RTRIM$(item$(itemnum%))) = 0 THEN printcolumn% = column%(itemnum%) ELSE printcolumn% = column%(itemnum%) + ((itemlen%(itemnum%)) - (LEN(LTRIM$(item$(itemnum%))))) IF printcolumn% < column%(itemnum%) THEN printcolumn% = column%(itemnum%) END IF GOTO ed1 END IF IF scan% = 119 THEN 'ctrl + home to start of line printcolumn% = column%(itemnum%) GOTO ed1 END IF IF (scan% = 80 OR scan% = 24) OR (scan% = 13 AND itemnum% <> numentry%) THEN 'Down Arrow or Enter for next field itemnum% = itemnum% + 1 IF itemnum% > numentry% THEN itemnum% = numentry% printcolumn% = column%(itemnum%) GOTO ed1 END IF IF scan% = 81 THEN ' pgdn to last line itemnum% = numentry% printcolumn% = column%(itemnum%) GOTO ed1 END IF IF scan% = 72 OR scan% = 5 THEN 'Up Arrow itemnum% = itemnum% - 1 IF itemnum% < 1 THEN itemnum% = 1 printcolumn% = column%(itemnum%) GOTO ed1 END IF IF scan% = 73 THEN 'pgup to top line itemnum% = 1 printcolumn% = column%(itemnum%) GOTO ed1 END IF IF scan% = 83 THEN 'Delete item$(itemnum%) = LEFT$(item$(itemnum%), printcolumn% - column%(itemnum%)) + MID$(item$(itemnum%), printcolumn% - column%(itemnum%) + 2, itemlen%(itemnum%) - printcolumn% + column%(itemnum%) - 1) + " " LOCATE row%(itemnum%), column%(itemnum%), 1, sc1%, sc2% PRINT item$(itemnum%); GOTO ed1 END IF IF scan% = 96 THEN ' control f3 to delete line item$(itemnum%) = SPACE$(itemlen%(itemnum%)) printcolumn% = column%(itemnum%) LOCATE row%(itemnum%), column%(itemnum%), 1, sc1%, sc2% PRINT item$(itemnum%); GOTO ed1 END IF IF scan% = 97 THEN 'Ctrl F4 to copy cutline$ = item$(itemnum%) GOTO ed1 END IF IF scan% = 98 THEN 'Ctrl F5 to paste item$(itemnum%) = cutline$ LOCATE row%(itemnum%), column%(itemnum%), 1, sc1%, sc2% PRINT LEFT$(item$(itemnum%), itemlen%(itemnum%)); GOTO ed1 END IF IF scan% = 82 THEN 'insert toggle IF insertkey% = 0 THEN insertkey% = 1 sc1% = 4 'change to 1/2 block cursor sc2% = 7 ELSE insertkey% = 0 sc1% = 6 sc2% = 7 END IF GOTO ed1 END IF IF scan% = 103 THEN 'ctrl f10 to exit scan% = 13 END IF ed3: IF scan% <> 13 THEN GOTO ed1 FOR entry% = 1 TO numentry% 'get rid of any ascii 0's tempstring$ = "" FOR leng% = 1 TO LEN(item$(entry%)) defaultstr$ = MID$(item$(entry%), leng%, 1) IF ASC(defaultstr$) = 0 THEN defaultstr$ = " " tempstring$ = tempstring$ + defaultstr$ NEXT leng% item$(entry%) = RTRIM$(tempstring$) NEXT entry% LOCATE , , 0 'turn off cursor COLOR sfg%, sbg% END SUB FUNCTION Justify$ (text$, just%, winleft%, winright%) REM function to justify text on a line within a window REM text$ is the string to be modified REM just% = one of the following REM 0 = not justiied REM 1 = left justified REM 2 = centre justified REM 3 = right justified REM winleft% = the leftmost column of the window REM winright% = the rightmost column of the window SELECT CASE just% CASE 0 'nothing needs to be done CASE 1 text$ = LTRIM$(text$) 'delete leading spaces CASE 2 centretext$ = LTRIM$(RTRIM$(text$)) IF LEN(centretext$) MOD 2 <> 0 THEN centretext$ = centretext$ + " " lenitm% = LEN(centretext$) 'strip leading & trailing spaces and find length of remaining text text$ = SPACE$(((winright% - winleft%) - lenitm%) \ 2) + centretext$ 'add proper number of spaces to centre the text CASE 3 lenitm% = LEN(LTRIM$(RTRIM$(text$))) 'find length of text with leading & trailing spaces deleted text$ = SPACE$((winright% - winleft%) - (lenitm% + 1)) + LTRIM$(RTRIM$(text$)) 'add proper number of spaces before the text so that text is right justified END SELECT Justify$ = text$ 'change justify$ to modified string END FUNCTION SUB WindowSub (wintop%, winbot%, winleft%, winright%, winforecolour%, winbackcolour%, wintext$(), winborder%) REM wintop% & winbot% are the top & bottom rows of the window REM winleft% & winright% are the left & right coloumns of the window REM fbg% 'window background colour REM winforecolour% 'window foreground colour REM wintext$() is an array containing the text of each line in the window REM winborder% is a flag which signals the program to add a border(frame) around the window REM 0 = no border, 1 = border fbg% = winbackcolour% 'window background colour ffg% = winforecolour% 'window foreground colour 'set up 2 dimensional array to store characters "under" the window DIM charascii%(wintop% TO winbot%, winleft% TO winright%) 'same as above but to store color attributes DIM charattrib%(wintop% TO winbot%, winleft% TO winright%) FOR winline% = wintop% TO winbot% FOR wincolumn% = winleft% TO winright% charascii%(winline%, wincolumn%) = SCREEN(winline%, wincolumn%) 'fill character array charattrib%(winline%, wincolumn%) = SCREEN(winline%, wincolumn%, 1) 'fill attribute array NEXT wincolumn% NEXT winline% textline% = 1 FOR winline% = wintop% TO winbot% 'put in window filled with LOCATE winline%, winleft% + 1 'spaces of background colour COLOR winforecolour%, winbackcolour% PRINT SPACE$(winright% - winleft%); LOCATE winline%, winleft% + 1 PRINT wintext$(textline%); 'print text in window textline% = textline% + 1 NEXT winline% IF winborder% = 1 THEN CALL Frame(wintop%, winbot%, winleft%, winright%) 'add fram if desired pause$ = INPUT$(1) 'pause ofter window is complete FOR winline% = wintop% TO winbot% 'delete window and replace FOR wincolumn% = winleft% TO winright% 'original screen LOCATE winline%, wincolumn% COLOR charattrib%(winline%, wincolumn%) MOD 16, (charattrib%(winline%, wincolumn%) AND &H70) \ 16 'parse stored colour attributes to foreground and background PRINT CHR$(charascii%(winline%, wincolumn%)) 'print stored characters NEXT wincolumn% NEXT winline% ERASE wintext$ 'get the arrays out of memory ERASE charascii% ERASE charattrib% END SUB