' +--------------------------------------------------------------------+ ' | Warning! Warning! Warning! | ' | | ' | To load program in the QuickBasic editor, you MUST load the | ' | QB quick library. | ' | | ' | Example: QB /L QB.QLB XPERTQB.BAS | ' +--------------------------------------------------------------------+ ' | | ' | - X P e r t Q B . B a s - | ' | | ' | | ' | Public Domain - FreeWare | ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | - ABOUT THE AUTHOR - | ' +--------------------------------------------------------------------+ ' | | ' | Hello. My name is Don Smith and I am a thirty-year retired teacher | ' | of Math/History/Spanish residing in Orange County, California. I | ' | am also a former six-year Sergeant of Marines. Who-Rah! On certain | ' | forums I am known as MarineDon.My email is: smithdonb@earthlink.net| ' | | ' +--------------------------------------------------------------------+ ' | - COPYING AND DISTIBUTING - | ' +--------------------------------------------------------------------+ ' | Since this code is public domain and freeware, anyone may freely | ' | copy and distribute it. If you use the QuickBasic code in one of | ' | your own programs, you do not have to cite my name as the author, | ' | and you may even change its name. | ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | XPertQB was written with QuickBASIC 4.5 which is a DOS programming | ' | language. XPertQB was designed to view, encrypt and deencrypt | ' | files with the long file names of WindowsXP. XPertQB is a Public | ' | Domain and Freeware program. Xpert.Bas uses plain ol' QuickBASIC | ' | and no special libraries other than QuickBasic's QB.Lib | ' +--------------------------------------------------------------------+ ' | Author: Don Smith | ' | Email : smithdonb@earthlink.net | ' | Date : 05/30/2007 | ' +--------------------------------------------------------------------+ ' | | ' | Compile Information: | ' | ------------------- | ' | BC: XPertQB | ' | LINK: XPertQB | ' | LIB: QB.Lib BCom45.Lib | ' | | ' +--------------------------------------------------------------------+ DEFINT A-Z '$DYNAMIC '$INCLUDE: 'QB.BI' 'requires RegType TYPE '===================================================================== CONST BYTES = 1000& '===================================================================== ' Four FUNCTIONS: '===================================================================== DECLARE FUNCTION Exist% (Spec$) DECLARE FUNCTION NewWord$ () DECLARE FUNCTION Rand& () DECLARE FUNCTION RandInteger% (a%, b%) '===================================================================== ' Nine SUBs: '===================================================================== 'DECLARE SUB ABSOLUTE (Par1 AS INTEGER, address AS INTEGER) DECLARE SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFor%, TitColrBak%, BoxColrFor%, BoxColrBak%, BoxStyle%, Shadow%, ShadowColr%, ClearColr%) DECLARE SUB EditSix (Row%, Col%, RCol%, Text$, TextType$, TextLen%, CCode%) DECLARE SUB Encrypt (FileName$) DECLARE SUB LongMenu (SM$(), LM$(), ULRowSM%, ULColSM%, LRRowSM%, LRColSM%, SMColrFG%, SMColrBG%, SMHiLiteFG%, SMHiLiteBG%, FKey$, MaxNum%, Selection%, ExitCode%, CurrentRow%) DECLARE SUB Pause (NumOfSeconds%) DECLARE SUB ProcesX (a$) DECLARE SUB RandShuffle (key$) DECLARE SUB SaveRestScrn (ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) DECLARE SUB TrueView (FileName$, ULRow%, ULCol%, LRRow%, LRCol%, FGColr%, BGColr%, TBColrFG%, TBColrBG%, TBNumColrFG%, TBNumColrBG%, EOFColrFG%, EOFColrBG%) '===================================================================== DIM SHARED Regs AS RegType Exten$ = COMMAND$ begin: Exten$ = RTRIM$(LTRIM$(Exten$)) Exten$ = UCASE$(Exten$) IF LEFT$(Exten$, 2) <> "*." THEN 'incorrect DOS usage error GOTO errorhandler ELSEIF Exten$ = "" THEN 'blank parameter error GOTO errorhandler END IF make.short.menu: '===================================================================== ' Make menu of "short" DOS file names '===================================================================== 'Make a file, $$$$FAKE.EXE, with short truncated DOS names: 'check to see whether or not the file extension exists Spec$ = Exten$ DoesExist% = Exist%(Spec$) IF DoesExist% = 0 THEN GOTO errorhandler END IF SHELL "dir /b " + Exten$ + ">" + "$$$$FAKE.SM" OPEN "$$$$FAKE.SM" FOR INPUT AS #8 DO IF EOF(8) THEN EXIT DO END IF LINE INPUT #8, TossOut$ MaxNum% = MaxNum% + 1 LOOP UNTIL EOF(8) CLOSE #8 REDIM SM$(MaxNum% + 1) OPEN "$$$$FAKE.SM" FOR INPUT AS #1 DO IF EOF(1) THEN EXIT DO END IF SMNum% = SMNum% + 1 LINE INPUT #1, SM$(SMNum%) IF SM$(SMNum%) = "$$$$FAKE.SM" THEN SMNum% = SMNum% - 1 END IF LOOP CLOSE #1 KILL "$$$$FAKE.SM" MaxNum% = 0 SMNum% = 0 make.long.menu: '===================================================================== ' Make menu of "long" WindowsXP file names '===================================================================== OPEN "Go.Bat" FOR OUTPUT AS #12 PRINT #12, "Dir /b" + " " + Exten$ + " " + ">" + " " + "$$$$FAKE.LM" CLOSE #12 SHELL "cmd /c go.bat" OPEN "$$$$FAKE.LM" FOR INPUT AS #9 DO IF EOF(9) THEN EXIT DO END IF LINE INPUT #9, TossOut$ MaxNum% = MaxNum% + 1 LOOP UNTIL EOF(9) CLOSE #9 REDIM LM$(MaxNum% + 1) OPEN "$$$$FAKE.LM" FOR INPUT AS #1 DO IF EOF(1) THEN EXIT DO END IF LMNum% = LMNum% + 1 LINE INPUT #1, LM$(LMNum%) LM$(LMNum%) = LEFT$(LM$(LMNum%), 56) IF LM$(LMNum%) = UCASE$("go.bat") THEN LMNum% = LMNum% - 1 ELSEIF LM$(LMNum%) = "$$$$FAKE.LM" THEN LMNum% = LMNum% - 1 END IF LOOP CLOSE #1 KILL "$$$$FAKE.LM" KILL "go.bat" LMNum% = 0 plaster.boxes: '===================================================================== ' Next, prepare screen by putting 3 boxes on screen: (1) Top ' box to the right, (2) Top box to the left and (3) The main ' box showing DOS file names to the left and WindowsXP file ' name to the right. '===================================================================== '===================================================================== ' SUB Boxboy displays the top box - left '===================================================================== COLOR 15, 1: CLS Title$ = "" ULRow% = 1 ULCol% = 2 LRRow% = 3 LRCol% = 17 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 1 BoxStyle% = 1 Shadow% = 0 ShadowColr% = 0 EdgeYN% = 0 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) COLOR 15, 1 LOCATE 2, 4: PRINT "WinXP Encrypt" '===================================================================== ' SUB Boxboy displays the top box - right '===================================================================== Title$ = "" ULRow% = 1 ULCol% = 20 LRRow% = 3 LRCol% = 78 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 1 BoxStyle% = 1 Shadow% = 0 ShadowColr% = 0 EdgeYN% = 0 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) TopLine$ = "VIEW: INFO: ENCRYPT: EXTENSION " LOCATE 2, 23: PRINT TopLine$ COLOR 11, 1 LOCATE 2, 30: PRINT "Enter" LOCATE 2, 44: PRINT "F1" LOCATE 2, 58: PRINT "F5" LOCATE 2, 74: PRINT "F7" '===================================================================== ' SUB Boxboy displays the box of menu file names, DOS file names ' to the right and WindowsXP file names to the left '===================================================================== Title$ = "" ULRow% = 6 ULCol% = 2 LRRow% = 24 LRCol% = 78 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 1 BoxStyle% = 1 Shadow% = 0 ShadowColr% = 0 EdgeYN% = 0 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) COLOR 15, 1 LOCATE 4, 2, 0 PRINT "Ú" + STRING$(16, "Ä") + "Â" + STRING$(59, "Ä") + "¿" LOCATE 5, 2, 0 PRINT "³" + SPACE$(2) + "DOS Names:" + SPACE$(4) + "³" + SPACE$(2) + "WindowsXP Long Names:" + SPACE$(36) + "³" LOCATE 6, 2, 0 PRINT "Ã" + STRING$(16, "Ä") + "Å" + STRING$(59, "Ä") + "´" LOCATE 24, 2, 0 PRINT "À" + STRING$(16, "Ä") + "Á"; LOCATE 25, 2: PRINT "EXIT: "; BottLine$ = "MOVE: " LOCATE 25, 15: PRINT BottLine$; COLOR 11, 1 LOCATE 25, 9: PRINT "Esc"; LOCATE 25, 22: PRINT "Up Arrow"; LOCATE 25, 33: PRINT "Down Arrow"; LOCATE 25, 46: PRINT "Page Up"; LOCATE 25, 56: PRINT "Page Down"; LOCATE 25, 68: PRINT "Home"; LOCATE 25, 75: PRINT "End"; '===================================================================== ' Set up for SUB LongMenu '===================================================================== Selection% = 1 'Start off with first pick of menu ULRowSM% = 7 ULColSM% = 5 LRRowSM% = 23 LRColSM% = 16 SMColrFG% = 15 SMColrBG% = 1 SMHiLiteFG% = 15 SMHiLiteBG% = 0 CurrentRow% = ULRowSM% begin.menu: FKey$ = "157" '===================================================================== ' Longmenu will show all file names, side by side with DOS file ' names to the left and long WindowsXP file names to the right. ' This is a special rewrite of the LongMenu SUB and cannot be ' used in other programs without eliminating all uses of LM$, ' meaning Long Menu names. If you would like the regular SUB ' LongMenu, download number #77, SUB LongMenu. '===================================================================== CALL LongMenu(SM$(), LM$(), ULRowSM%, ULColSM%, LRRowSM%, LRColSM%, SMColrFG%, SMColrBG%, SMHiLiteFG%, SMHiLiteBG%, FKey$, MaxNum%, Selection%, ExitCode%, CurrentRow%) SM$(Selection%) = RTRIM$(LTRIM$(SM$(Selection%))) IF ExitCode% = 27 THEN ' COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END ' 'For F keys use ExitCode% = 1 to 0,but set FKey$ = "150", etc ELSEIF ExitCode% = 1 THEN ' GOSUB save.screen GOSUB documentation FileName$ = "XPertQB.Txt" GOSUB fullview KILL "XPertQB.Txt" GOSUB restore.screen ExitCode% = 0 GOTO begin.menu ELSEIF ExitCode% = 5 THEN ' GOSUB save.screen GOSUB encrypt.da.file GOSUB restore.screen ExitCode% = 0 GOTO begin.menu ELSEIF ExitCode% = 7 THEN ' Exten2$ = Exten$ GOSUB change.extension IF NoFind% = 1 THEN NoFind% = 0 GOTO begin.menu END IF ExitCode% = 0 MaxNum% = 0 GOTO begin ELSEIF ExitCode% = 13 THEN ' GOSUB save.screen FileName$ = SM$(Selection%) GOSUB fullview GOSUB restore.screen ExitCode% = 0 GOTO begin.menu ELSE ExitCode% = 0 GOTO begin.menu END IF save.screen: '===================================================================== ' SUB SaveRestScrn - saves entire screen: 25 rows and 80 columns '===================================================================== REDIM ReadLine$(25) REDIM ReadColr%(25, 80) SR.UL.Row% = 1 SR.UL.Col% = 1 SR.LR.Row% = 25 SR.LR.Col% = 80 SaveOrRest% = 1 CALL SaveRestScrn(ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) RETURN restore.screen: '===================================================================== ' SUB SaveRestScrn - restores entire screen: 25 rows and 80 columns '===================================================================== SR.UL.Row% = 1 SR.UL.Col% = 1 SR.LR.Row% = 25 SR.LR.Col% = 80 SaveOrRest% = 2 CALL SaveRestScrn(ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) ERASE ReadLine$: ERASE ReadColr% RETURN error.extension: '===================================================================== ' SUB BoxBoy with error message '===================================================================== Title$ = "- Oops! -" ULRow% = 10 ULCol% = 30 LRRow% = 14 LRCol% = 52 TitleRow% = 11 TitleCol% = 33 TitColrFG% = 15 TitColrBG% = 4 BoxColrFG% = 15 BoxColrBG% = 4 BoxStyle% = 1 Shadow% = 1 ShadowColr% = 7 EdgeYN% = 1 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) LOCATE 13, 33: PRINT "Sorry - Unable to find your extension." LOCATE 14, 33: PRINT "Press any key to continue." DO: LOOP WHILE INKEY$ = "" GOTO begin.menu errorhandler: COLOR 15, 1: CLS '===================================================================== ' SUB BoxBoy with error message of an opening program error '===================================================================== Title$ = "" ULRow% = 2 ULCol% = 9 LRRow% = 22 LRCol% = 71 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 1 BoxStyle% = 1 Shadow% = 0 ShadowColr% = 0 EdgeYN% = 0 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) LineError$ = "Ã" + STRING$(62, "Ä") + "´" COLOR 12, 1 LOCATE 3, 17: PRINT " <<>>" COLOR 15, 1 LOCATE 4, 9: PRINT LineError$ LOCATE 5, 17: PRINT "Either no parameter was entered on the command" LOCATE 6, 17: PRINT "line, the parameter was entered incorrectly, or" LOCATE 7, 17: PRINT "there were no matching files found." COLOR 11, 1 LOCATE 9, 27: PRINT "Example: XPertQB *.TXT"; COLOR 15, 1 LOCATE 11, 17: PRINT "Example to view all the files on the current"; LOCATE 12, 17: PRINT "directory. Type Í" COLOR 11, 1 LOCATE 14, 27: PRINT "Example: XPertQB *.* "; COLOR 15, 1 LOCATE 16, 9: PRINT LineError$; LOCATE 17, 14: PRINT CHR$(34) + "XPertQB.Exe" + CHR$(34); " is a program which will display both DOS" LOCATE 18, 14: PRINT "names and long Windows names, affording the user a way"; LOCATE 19, 14: PRINT "to view then encrypt/decrypt a program with password."; LOCATE 20, 9: PRINT LineError$; LOCATE 21, 27, 0: COLOR 14, 1: PRINT "Press Any Key To Continue"; DO: LOOP WHILE INKEY$ = "" COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7 END change.extension: GOSUB save.screen '===================================================================== ' SUB BoxBoy with change extension box '===================================================================== Title$ = "Change Extension =" ULRow% = 10 ULCol% = 20 LRRow% = 18 LRCol% = 60 TitleRow% = 11 TitleCol% = 33 TitColrFG% = 15 TitColrBG% = 4 BoxColrFG% = 15 BoxColrBG% = 4 BoxStyle% = 1 Shadow% = 1 ShadowColr% = 7 EdgeYN% = 1 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) LOCATE 14, 21: PRINT CHR$(195) + STRING$(40, "Ä") + CHR$(180); LOCATE 15, 23: PRINT "Enter file extension and press ."; LOCATE 16, 23: PRINT "To exit without entering an extension,"; LOCATE 17, 23: PRINT "press on blank or ."; COLOR 11, 4 LOCATE 15, 55: PRINT "Enter"; LOCATE 17, 30: PRINT "Enter"; LOCATE 17, 50: PRINT "Esc"; '===================================================================== ' SUB EditSix - input new extension '===================================================================== Row% = 13 Col% = 41 RCol% = 44 Text$ = "" TextType$ = "" TextLen% = 3 CCode% = 0 CALL EditSix(Row%, Col%, RCol%, Text$, TextType$, TextLen%, CCode%) IF CCode% = 27 THEN NoFind% = 1 GOSUB restore.screen RETURN END IF IF Text$ = "" THEN NoFind% = 1 GOSUB restore.screen RETURN END IF Exten$ = Text$ Exten$ = "*." + Exten$ DoesExist% = Exist%(Exten$) IF DoesExist% = 0 THEN GOSUB no.find.extension Exten$ = Spec$ NoFind% = 1 RETURN ELSE GOSUB restore.screen RETURN END IF no.find.extension: GOSUB restore.screen '===================================================================== ' SUB BoxBoy with error message - unable to find extension '===================================================================== Title$ = "Oops!" ULRow% = 9 ULCol% = 16 LRRow% = 15 LRCol% = 62 TitleRow% = 10 TitleCol% = 37 TitColrFG% = 11 TitColrBG% = 4 BoxColrFG% = 15 BoxColrBG% = 4 BoxStyle% = 1 Shadow% = 1 ShadowColr% = 7 EdgeYN% = 1 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) COLOR 15, 4 LOCATE 12, 20, 0: PRINT "The XPertQB program was unable to find any"; LOCATE 13, 20, 0: PRINT "files with the " + UCASE$(Exten$) + " extension. Press any"; LOCATE 14, 20, 0, 0, 0: PRINT "key to continue."; COLOR 11, 4: LOCATE 13, 35: PRINT UCASE$(Exten$); DO: LOOP WHILE INKEY$ = "" RETURN encrypt.da.file: '===================================================================== ' SUB BoxBoy with encryption box '===================================================================== Title$ = "" ULRow% = 10 ULCol% = 9 LRRow% = 18 LRCol% = 70 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 4 BoxStyle% = 1 Shadow% = 1 ShadowColr% = 7 EdgeYN% = 1 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) Message1$ = "<<< Encrypt Or Deencrypt Routine >>>" Message2$ = "This routine will encrypt/deencrypt: " Message3$ = "If this file has already been encrypted, this step" Message4$ = "will deencrypt the file back to its orginal form." Message5$ = "Proceed ? (Y/N)" line$ = "Æ" + STRING$(61, 205) + "µ" COLOR 11, 4 LOCATE 11, 23, 0: PRINT Message1$ COLOR 15, 4 LOCATE 12, 10, 0: PRINT line$ LOCATE 13, 15, 0: PRINT Message2$ COLOR 11, 4 LOCATE 13, 52, 0: PRINT SM$(Selection%) COLOR 15, 4 LOCATE 14, 15, 0: PRINT Message3$ LOCATE 15, 15, 0: PRINT Message4$ LOCATE 16, 10, 0: PRINT line$ LOCATE 17, 30, 0: PRINT Message5$ COLOR 11, 4 LOCATE 17, 42, 0: PRINT "Y" LOCATE 17, 44, 0: PRINT "N" DO DO k$ = INKEY$ LOOP UNTIL LEN(k$) > 0 k% = CVI(k$ + CHR$(0)) IF k% = 89 OR k% = 121 THEN 'Y,y GOTO encrypt.proceed ELSEIF k% = 78 OR k% = 110 THEN 'N,n EXIT DO ELSEIF k% = 27 THEN 'esc EXIT DO END IF LOOP LOCATE 1, 1, 0, 0, 0 RETURN encrypt.proceed: '===================================================================== ' SUB BoxBoy with box requesting the user to input a password '===================================================================== Title$ = "" ULRow% = 10 ULCol% = 9 LRRow% = 20 LRCol% = 70 TitleRow% = 1 TitleCol% = 1 TitColrFG% = 1 TitColrBG% = 1 BoxColrFG% = 15 BoxColrBG% = 4 BoxStyle% = 1 Shadow% = 1 ShadowColr% = 7 EdgeYN% = 1 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) Message1$ = "Give Password Below For :" Message2$ = " (1) The password is UPPER and lower case sensitive" Message3$ = " (2) Forget the password at your peril!" COLOR 15, 4 LOCATE 11, 19, 0: PRINT Message1$ COLOR 11, 4 LOCATE 11, 46, 0: PRINT SM$(Selection%) COLOR 15, 4 LOCATE 11, 19, 0: PRINT Message1$ LOCATE 12, 10, 0: PRINT "Ã" + STRING$(61, "Ä") + "´" LOCATE 13, 11, 0: PRINT Message2$ LOCATE 14, 11, 0: PRINT Message3$ LOCATE 13, 12, 0: PRINT "CAUTION:" LOCATE 14, 12, 0: PRINT "CAUTION:" LOCATE 17, 10, 0: PRINT "Ã" + STRING$(61, "Ä") + "´" LOCATE 18, 19, 0: PRINT "Enter a password and press or," LOCATE 19, 19, 0: PRINT "press to immediately exit the routine." COLOR 11, 4 LOCATE 18, 47, 0, 0: PRINT "ENTER" LOCATE 19, 26, 0, 0: PRINT "Esc" give.password: '===================================================================== ' SUB EditSix where user inputs a password '===================================================================== Row% = 16 Col% = 15 RCol% = 69 Text$ = "" TextType$ = "" TextLen% = 53 CCode% = 0 LOCATE Row%, Col%: COLOR FGColr%, BGColr%: PRINT STRING$(LenStr%, " "); CALL EditSix(Row%, Col%, RCol%, Text$, TextType$, TextLen%, CCode%) EdW$ = RTRIM$(LTRIM$(Text$)) IF CCode% = 13 THEN GOSUB filecrypt RETURN ELSEIF CCode% = 27 THEN RETURN ELSEIF LEN(Text$) = 54 THEN GOTO give.password END IF GOTO give.password filecrypt: '======================================================================= ' Encryption routine uses the following FUNCTIONs and SUBs: '======================================================================= ' FUNCTION NewWord$ ().......Returns a pseudorandom word of a ' possibly speakable form. ' ' DECLARE FUNCTION Rand& ()..Returns a pseudrandom long integer in ' range of 0 through 999999999. ' ' DECLARE FUNCTION RandInteger% (a%, b%)...Returns a pseudorandom ' integer in the range ' a% to b% inclusive. '======================================================================= ' SUB RandShuffle (key$)..Creates an original table of pseudorandom ' long integers for use by the FUNCTION Rand& ' ' ' SUB ProcesX (a$)........Enciphers a string by XORing with ' pseudorandom bytes. '======================================================================= '======================================================================= ' The line below, cmd$ = SM$(Selection%) + " " + EdW$, means: '======================================================================= ' SM$(Selection%) = The file to be viewed. ' " " = One space. ' EdW$ = The password. '======================================================================= cmd$ = SM$(Selection%) + " " + EdW$ DIM SHARED R&(1 TO 100) 'for use in SUB RandShuffle cmd$ = cmd$ + " " firstSpace% = INSTR(cmd$, " ") FileName$ = LEFT$(cmd$, firstSpace% - 1) 'Grab the rest of the command line as the cipher key: key$ = LTRIM$(MID$(cmd$, firstSpace% + 1)) 'Prepare the pseudorandom numbers using the key for shuffling CALL RandShuffle(key$) 'Open up the file: OPEN FileName$ FOR BINARY AS #1 fileLength& = LOF(1) 'Process the file in manageable pieces: a$ = SPACE$(BYTES) count% = fileLength& \ BYTES 'Loop through the file FOR i% = 0 TO count% j& = i% * BYTES + 1 IF i% = count% THEN a$ = SPACE$(fileLength& - BYTES * count%) END IF GET #1, j&, a$ CALL ProcesX(a$) PUT #1, j&, a$ NEXT i% CLOSE #1 ERASE R& COLOR 15, 0 LOCATE 16, RCol% - TextLen% - 1, 0: PRINT SPACE$(TextLen%) COLOR 14, 0 LOCATE 16, 20, 0: PRINT "- - - Routine Successfully Completed - - -" SLEEP (1) RETURN fullview: '===================================================================== ' SUB TrueView sets up the file viewer '===================================================================== ULRow% = 2 'Upper left row to place text. ULCol% = 1 'Upper left column to place text. LRRow% = 24 'Lower right row to place text. LRCol% = 80 'Lower right column to place text. FGColr% = 15 'Foreground color of text (0-15). BGColr% = 1 'Back ground color of text (0-7). TBColrFG% = 0 'Foreground color of top/bottom strips (0-15). TBColrBG% = 7 'Background color of the top/bottom strips (0-7). TBNumColrFG% = 0 'Foreground color of top line numbering (0-15). TBNumColrBG% = 7 'Background color of bottom line numbering (0-7). EOFColrFG% = 15 'Foreground color of "End Of File" message (0-15). EOFColrBG% = 4 'Background color of "End Of File" message (0-7). CALL TrueView(FileName$, ULRow%, ULCol%, LRRow%, LRCol%, FGColr%, BGColr%, TBColrFG%, TBColrBG%, TBNumColrFG%, TBNumColrBG%, EOFColrFG%, EOFColrBG%) RETURN documentation: '======================================================================================= ' First print file "XPertQB.Txt", view it with SUB TrueView, then kill "XPertQB.Txt" '======================================================================================= OPEN "XPertQB.Txt" FOR OUTPUT AS #1 PRINT #1, SPACE$(80) PRINT #1, " ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»" PRINT #1, " º ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ º" PRINT #1, " º ³ ³ º" PRINT #1, " º ³ X P e r t Q B P r o g r a m ³ º" PRINT #1, " º ³ ³ º" PRINT #1, " º ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ º" PRINT #1, " ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ" PRINT #1, " ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " ³ This File Is: XPertQB.Txt ³" PRINT #1, " ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´" PRINT #1, " ³ Today's Date Is: 08/01/2005 ³" PRINT #1, " ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, SPACE$(80) PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º PURPOSE ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " This is the documentation file for the XPertQB Program." PRINT #1, " XPertQB was designed to show the longer file names in the" PRINT #1, " WindowsXP environment and to encrypt them and deencrypt them." PRINT #1, " The XPertQB Program is a Public Domain and FreeWare Program." PRINT #1, " It was written with QuickBASIC 4.5 which is a DOS based" PRINT #1, " programming language." PRINT #1, SPACE$(80) PRINT #1, " It is simple to run XPertQB. First enter it's name at the prompt," PRINT #1, " followed by a file extension. Example: XPERTQB *.TXT. In this" PRINT #1, " case, all the files with the file extension of .TXT will be loaded" PRINT #1, " into XPertQB. The asterisk must be included. To import ALL the" PRINT #1, " files on the current directory, use: XPertQB *.* (Yes, that" PRINT #1, " is asterisk-dot-asterisk)." PRINT #1, SPACE$(80) PRINT #1, " The program opens showing DOS names in a viewing window to the" PRINT #1, " left in their normal, truncated 8-dot-3 form. The Windows' names" PRINT #1, " will appear on the right in their own viewing window. The long" PRINT #1, " Windows names show only the first 56 characters, but that should" PRINT #1, " contain enough information to tell what the file is. Use the up" PRINT #1, " or down arrow keys and press to to view a file, press" PRINT #1, " to view the documentation file or press to encrypt a" PRINT #1, " file." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º View A File ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " When you press , the file at the block cursor will be" PRINT #1, " placed into a viewing browser. The browser is designed to view" PRINT #1, " plain ASCII text file files. If you view a non-text file" PRINT #1, " program such as an executable EXE file, the browser will NOT" PRINT #1, " lock up; the screen might display complete gibberish, just a" PRINT #1, " few stray symbols or perhaps nothing at all will be displayed." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º View The Documentation File ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " To view this documentation/help file, " + CHR$(34) + "XPertQB.Txt" + CHR$(34) + ", just press" PRINT #1, " . When is pressed, the XPertQB program generates a new" PRINT #1, " documentation file on the fly each time. When the user exits" PRINT #1, " by pressing , the file " + CHR$(34) + "XPertQB.Txt" + CHR$(34) + " is deleted." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º Encrypt/Deencrypt A File ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " Press to bring up the encryption window. The encryption" PRINT #1, " routine is used both to encrypt and later deencrypt the targeted" PRINT #1, " file. Make sure that the same exact password is entered each time." PRINT #1, " For example, " + CHR$(34) + "WORD" + CHR$(34) + " and " + CHR$(34) + "word" + CHR$(34) + " will be seen as different passwords," PRINT #1, " because the encryption routine is both upper and lower case" PRINT #1, " sensitive. Be super careful because even spaces count. For" PRINT #1, " example, [Space]ABC is not the same as ABC. Up to 53 alphanumeric" PRINT #1, " characters may be entered as a password. It is strongly recommended" PRINT #1, " to practice with " + CHR$(34) + "scratch" + CHR$(34) + " files until a sufficient amount of" PRINT #1, " practice is acquired. It is also strongly recommended to ALWAYS" PRINT #1, " make back up files in all cases. Use EXTREME CAUTION with the" PRINT #1, " encryption routine!" PRINT #1, SPACE$(80) PRINT #1, " The encryption model used at this juncture is what I call an" PRINT #1, " in/out, or back/&forth routine. It goes into encryption and out" PRINT #1, " of encryption, in and out. It does not keep adding encryption" PRINT #1, " layers on top of encryption layers. That is what does. If" PRINT #1, " you press and give a password, then call on it again and" PRINT #1, " give another password, to retrieve your file, you'll have to" PRINT #1, " again give the two passwords in reverse order. The encryption" PRINT #1, " algorium used here is not world class, CIA level encryption." PRINT #1, " It is just a simple encryption algorium that totally scrambles" PRINT #1, " the file." PRINT #1, SPACE$(80) PRINT #1, " I tested XPertQB on HTM/HTML files, Microsoft Word (2002) DOC" PRINT #1, " files, executable EXE files, and plain ASCII text TXT files." PRINT #1, " It worked for me to perfection." PRINT #1, SPACE$(80) PRINT #1, " The only problem I had was it trying to view the Microsoft" PRINT #1, " Word (2002) files before and after encryption. Since Word" PRINT #1, " DOC files are not regular text files, the browser showed" PRINT #1, " only scrambled files both times. This is how it should be." PRINT #1, " I even encrypted an executable EXE file and it worked fine" PRINT #1, " after being deencrypted. Needless to say the browser showed" PRINT #1, " a scrambled screen before and after encryption. My point is" PRINT #1, " this, do NOT rely on the browser to tell you if a file has" PRINT #1, " or has not been encrypted. You, the user, must remember if" PRINT #1, " a particular files is under encryption or not. The browser" PRINT #1, " in fact was designed for regular ASCII characters and will" PRINT #1, " stop inputing the scrambled viewing file after encountering" PRINT #1, " an end-of-file character." PRINT #1, SPACE$(80) PRINT #1, " This is an example of what an encrypted file might look like:" PRINT #1, SPACE$(80) PRINT #1, " †x?òÓC5¾Ï@púÔG&û†mpöÇ]pðÉ<äÄK<°" PRINT #1, " $]”†j9ìÃM$ñÔWpñÀ3¤úJ?íú^ñÜÁ\1óú" PRINT #1, " «$pÈÉB%óÃûÔG1ò†ä%óÄK&¾Ï]pÚå³" PRINT #1, " ¬#Zs®‘b¦‰䮓p®‘d¬†o¾†p¾†äçÜ" PRINT #1, " ÈÉB%óÃûÔG1ò†ä%óÄKñ¾Ï]pÚå³”m" PRINT #1, " ¬#Z®‘b¦‰L䮓p®‘d¬†o¾†p¾†p¾KÏ" PRINT #1, SPACE$(80); "" PRINT #1, " Do not take my word that XPertQB works. Try it out for yourself." PRINT #1, " Use the " + CHR$(34) + "Save As..." + CHR$(34) + " feature of a word processor to make" PRINT #1, " practice, scratch files to practice on." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º PUBLIC DOMAIN AND FREEWARE ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " I consider the XPertQB program to be in the Public Domain and " PRINT #1, " FreeWare. I hereby release it to the Public Domain on this " PRINT #1, " date of: 08/01/2005." PRINT #1, "" PRINT #1, " The QuickBASIC code of the program is completely free to use" PRINT #1, " by another programmer, and may be modified to any extent." PRINT #1, " Even the name of the program may be changed. My name" PRINT #1, " does NOT need to be cited as the auther of the program." PRINT #1, " The documentation file may be changed in any way that" PRINT #1, " another programmer wishes." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º CAUTION ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " This is a public domain program! DO NOT accept anything" PRINT #1, " for granted. Use scratch files to try out everything. The" PRINT #1, " author personally feels that the program is bug free, however," PRINT #1, " as in every program there might be an unknown bug. If so," PRINT #1, " contact the author through EMail: smithdonb@earthlink.net" PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º DISCLAIMER ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " The author of the XPertQB program accepts no liability for " PRINT #1, " damages resulting from its use or misuse. No warranty nor" PRINT #1, " guarantee of the XPertQB program is given by the author;" PRINT #1, " in fact they are specifically not given. The program is" PRINT #1, " furnished " + CHR$(34) + "AS IS" + CHR$(34) + ". Any damages resulting from the use of" PRINT #1, " the XPertQB program is placed on and accepted by the user" PRINT #1, " of the program." PRINT #1, SPACE$(80) PRINT #1, " A condition of use of the XPertQB program is that the user" PRINT #1, " accept fully the disclaimer stated above. Please read" PRINT #1, " carefully the CAUTION given above." PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º ACKNOWLEDGEMENTS - Full Moon Software ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " Full Moon Software:" PRINT #1, " ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ" PRINT #1, " The XPertQB program was written with QuickBASIC 4.5. I did" PRINT #1, " not use any special libraries or assembly language routines" PRINT #1, " in writing it. Having said that however, I do use from time" PRINT #1, " to time three great toolboxes from Crescent Software. They" PRINT #1, " are: QuickPak, PDQ and QuickScreen. Crescent Software was" PRINT #1, " sold to Progress Software. The original owner and programmer" PRINT #1, " of Crescent Software, Ethen Winer, took back the MS-DOS" PRINT #1, " toolboxes so that they still would be available to MS-DOS" PRINT #1, " programmers. He now operates Full Moon Software where these" PRINT #1, " toolboxes may be obtained. These three toolboxes have hundreds" PRINT #1, " of routines. Using their included libraries instead of BRUN45.Lib" PRINT #1, " or BCOM45.Lib and utilizing their assembly written routines," PRINT #1, " makes for an extremely tight, executable code very close to" PRINT #1, " the tiny size and speed of an assembly language program. I" PRINT #1, " especially enjoy using the QuickScreen program, Qscr.Exe," PRINT #1, " which makes short work of converting a " + CHR$(34) + "BSaved" + CHR$(34) + " BSV file" PRINT #1, " into a linkable .OBJ file." PRINT #1, SPACE$(80) PRINT #1, " Ethan Winer's internet site:" PRINT #1, " ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ" PRINT #1, " http://www.ehtanwiner.com" PRINT #1, "" PRINT #1, " Ethan Winer's Mailing Address:" PRINT #1, " ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ" PRINT #1, " FULL MOON SOFTWARE" PRINT #1, " 34 Cedar Vale Drive" PRINT #1, " New Milford, CT 06776" PRINT #1, "" PRINT #1, " (Voice) 860-350-8188" PRINT #1, " (Fax) 860-350-6130" PRINT #1, " (Email) ethan@ethanwiner.com" PRINT #1, SPACE$(80) PRINT #1, " ÖÄÄÄÄÄÄÄÄÄÄÄÄ¿" PRINT #1, " º AUTHOR ³" PRINT #1, " ÓÄÄÄÄÄÄÄÄÄÄÄÄÙ" PRINT #1, " Hi! My name is Don Smith and I a thirty-year retired teacher of" PRINT #1, " Math/History/Spanish residing in Orange County, California. I am" PRINT #1, " also a six-year former Sergeant of Marines. Who-Ray!. On certain" PRINT #1, " forums, I am known as MarineDon. Email: smithdonb@earthlink.net" PRINT #1, SPACE$(80) PRINT #1, " ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»" PRINT #1, " º º" PRINT #1, " º Author : Donald Bernard Smith º" PRINT #1, " ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ" PRINT #1, " º Earthlink EMail : smithdonb@earthlink.net º" PRINT #1, " º º" PRINT #1, " ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ" PRINT #1, SPACE$(80) CLOSE #1 RETURN SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) ' +--------------------------------------------------------------------+ ' | | ' | SUB BoxBoy | ' | | ' +--------------------------------------------------------------------+ ' | Not counting REM (') lines, SUB BoxBoy has 121 lines. | ' +--------------------------------------------------------------------+ ' | The SUB BoxBoy was written by Don Smith. This BoxBoy is the | ' | lastest iteration of the SUB - written 12-01-2002. Other | ' | programmers, or anyone else for that matter, may use this SUB | ' | without naming me as the author, and they may modify the code | ' | in any way they see fit. | ' | | ' | Don's EMail: smithdonb@earthlink.net | ' | | ' | This SUB only saves that portion of the underlying screen under | ' | the box and repaints with a shadow. So recommend using the SUB | ' | SaveRestScrn to save/restore the complete screen, or a larger | ' | portion of the screen than the box. | ' +-------------+------------------------------------------------------+ ' | Title$ | The title of the menu. To make a box without a title,| ' | | use: Title$ = "". When there is no Title, the cross | ' | | bar is not deployed. | ' +-------------+------------------------------------------------------+ ' | ULRow% | The upper left row to place the box. | ' +-------------+------------------------------------------------------+ ' | ULCol% | The upper left column to place the box. | ' +-------------+------------------------------------------------------+ ' | LRRow% | The lower right row to place the box. | ' +-------------+------------------------------------------------------+ ' | LRCol% | The lower right column to place the box. | ' +-------------+----------------------------------+-------------------+ ' | TitleRow% | The row to place the title. | If Title$ = "" | ' +-------------+----------------------------------| (or NO title), | ' | TitleCol% | The column to place the title. | report these four | ' +-------------+----------------------------------| values as zero (0)| ' | TitColrFG% | The foreground color of the title| . . . . . . . . | ' +-------------+----------------------------------| Example -> | ' | TitColrBG% | The background color of the title| TitColrFG% = 0 | ' +-------------+----------------------------------+-------------------+ ' | BoxColrFG% | The foreground color of the box itself. | ' +-------------+------------------------------------------------------+ ' | BoxColrBG% | The back ground color of the box. | ' +-------------+------------------------------------------------------+ ' | BoxStyle% | BoxStyle% = 0 (No line around box) | ' | | BoxStyle% = 1 (Single line around box | ' | | BoxStyle% = 2 (Double line around box | ' | | BoxStyle% = 3 (Solid line around box | ' +-------------+------------------------------------------------------+ ' | Shadow% | If Shadow% equals 0, there will be no shadow. | ' | | If Shadow% equals 1, there will be a right shadow. | ' | | If Shadow% equals 2, there will be a left shadow | ' | +------------------------------------------------------+ ' | | NOTE #1: | ' | | ------- | ' | | When a shadow is used, the underlying text will | ' | | be saved and printed with the ShadeColr% (just | ' | | below). This causes the shadow to look like a | ' | | real shadow. | ' | | | ' | | NOTE #2: | ' | | ------- | ' | | If the first four values of BoxBoy are 1, 1, 25, 80, | ' | | in other words a full screen, please set Shadow% = 0;| ' | | otherwise an error will result (no room for shadow). | ' +-------------+------------------------------------------------------+ ' | ShadowColr% | The ShadowColr% is the foreground color of the | ' | | shadow. The background color will always be | ' | | black. Either choose ShadowColr% = 7 or | ' | | ShadowColr% = 8. | ' | | | ' | | ShadowColr% = 7 saves the foreground color and | ' | | changes it to a shade darker, if possible. For | ' | | example, a bright white on blue (COLOR 15, 1) | ' | | becomes dim white on black (COLOR 7, 0). A bright | ' | | blue on blue (COLOR 9, 1) becomes regular blue | ' | | on black (COLOR 1, 0). Very realistic. | ' | | | ' | | ShadowColr% = 8 saves the foreground and reprints | ' | | it as COLOR 8, 0. Darker then ShadowColr% = 7 | ' +-------------+----------------+-------------------------------------+ ' | EdgeYN% | EdgeYN% = 0 | Do NOT print an edge of one space | ' | | | with BoxColrFG% color on the right | ' | | | and left edges of the box. | ' | +----------------+-------------------------------------+ ' | | EdgeYN% = 1 | YES, DO print an edge of one space | ' | | | with BoxColrFG% color on the right | ' | | | and left edges of the box. | ' | +----------------+-------------------------------------+ ' | | What does it mean to "print an edge of one space | ' | | with BoxColrFG% color on the right and left edges | ' | | of the box". Well, I will attempt to demonstrate | ' | | by drawing the boxes with non-extended ASCII | ' | | characters. The X's represent a shadow to the | ' | | right. | ' | | | ' | | NO EDGE RIGHT/LEFT 1 SPACE EDGE RIGHT/LEFT | ' | | ~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~ | ' | | (EdgeYN% = 0) (EdgeYN% = 1 | ' | | | ' | | +-----------------+ +-------------------+ | ' | | |+---------------+| | +---------------+ | | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | |+---------------+|XX | +---------------+ |XX | ' | | +-----------------+XX +-------------------+XX | ' | | XXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXX | ' | | | ' +-------------+------------------------------------------------------+ IF EdgeYN% > 1 OR EdgYN% < 0 THEN EdgeYN% = 0 END IF IF ULCol% <= 1 THEN ULCol% = 1 END IF IF LRCol% = 80 THEN IF Shadow% > 0 THEN LRCol% = 78 ELSEIF Shadow% = 0 THEN LRCol% = 79 END IF END IF make.box: IF BoxStyle% = 0 THEN 'No Lines ULCorner$ = CHR$(255) URCorner$ = CHR$(255) HorLineTop$ = CHR$(255) HorLineBot$ = CHR$(255) LeftSide$ = CHR$(255) RightSide$ = CHR$(255) VertLine$ = CHR$(255) LLCorner$ = CHR$(255) LRCorner$ = CHR$(255) ELSEIF BoxStyle% = 1 THEN 'Single Line ULCorner$ = CHR$(218) URCorner$ = CHR$(191) HorLineTop$ = CHR$(196) HorLineBot$ = CHR$(196) LeftSide$ = CHR$(195) RightSide$ = CHR$(180) VertLine$ = CHR$(179) LLCorner$ = CHR$(192) LRCorner$ = CHR$(217) ELSEIF BoxStyle% = 2 THEN 'Double Line ULCorner$ = CHR$(201) URCorner$ = CHR$(187) HorLineTop$ = CHR$(205) HorLineBot$ = CHR$(205) LeftSide$ = CHR$(199) RightSide$ = CHR$(182) VertLine$ = CHR$(186) LLCorner$ = CHR$(200) LRCorner$ = CHR$(188) ELSEIF BoxStyle% = 3 THEN 'Solid line ULCorner$ = CHR$(219) URCorner$ = CHR$(219) HorLineTop$ = CHR$(223) HorLineBot$ = CHR$(220) LeftSide$ = CHR$(219) RightSide$ = CHR$(219) VertLine$ = CHR$(219) LLCorner$ = CHR$(219) LRCorner$ = CHR$(219) END IF IF Shadow% > 0 THEN IF EdgeYN% = 1 THEN IF Shadow% = 1 THEN LeftLimit% = ULCol% + 2 RightLimit% = LRCol% + 5 ELSEIF Shadow% = 2 THEN LeftLimit% = ULCol% - 2 RightLimit% = LRCol% END IF ELSEIF EdgeYN% = 0 THEN IF Shadow% = 1 THEN LeftLimit% = ULCol% + 2 RightLimit% = LRCol% + 3 ELSEIF Shadow% = 2 THEN LeftLimit% = ULCol% - 2 ightLimit% = LRCol% - 1 END IF END IF REDIM ReadLine$(25): REDIM ReadColr%(25, 80) FOR ViewIt% = ULRow% + 1 TO LRRow% + 1 FOR Horizon% = LeftLimit% TO RightLimit% ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) ReadColr%(ViewIt%, Horizon%) = SCREEN(ViewIt%, Horizon%, 1) NEXT NEXT FOR FindRow% = ULRow% + 1 TO LRRow% + 1 FOR ScrnCol% = LeftLimit% TO RightLimit% LOCATE FindRow%, ScrnCol%, 0 OneColr% = ReadColr%(FindRow%, ScrnCol%) FGScrnColr% = OneColr% MOD 16 'make colors brighter: 'IF FGScrnColr% = 0 THEN FGScrnColr% = 7 'IF FGScrnColr% = 9 THEN FGScrnColr% = 1 'IF FGScrnColr% = 10 THEN FGScrnColr% = 2 'IF FGScrnColr% = 11 THEN FGScrnColr% = 3 'IF FGScrnColr% = 12 THEN FGScrnColr% = 4 'IF FGScrnColr% = 13 THEN FGScrnColr% = 5 'IF FGScrnColr% = 14 THEN FGScrnColr% = 7 'IF FGScrnColr% = 15 THEN FGScrnColr% = 7 BGScrnColr% = OneColr% \ 16 IF ShadowColr% = 7 THEN 'COLOR FGScrnColr%, 0 COLOR 7, 0 ELSEIF ShadowColr% = 8 THEN COLOR 8, 0 END IF IF Shadow% = 1 THEN PRINT MID$(ReadLine$(FindRow%), ScrnCol% - (ULCol% + 1)); ELSEIF Shadow% = 2 THEN PRINT MID$(ReadLine$(FindRow%), ScrnCol% - (ULCol% - 3)); END IF NEXT NEXT ERASE ReadLine$: ERASE ReadColr% END IF IF EdgeYN% = 1 THEN Edge$ = " " END IF Title.Length% = LEN(Title$) COLOR BoxColrFG%, BoxColrBG% 'ÚÄÄÄ¿ or ÉÍÍÍ» LOCATE ULRow%, ULCol%, 0 PRINT Edge$ + ULCorner$ + STRING$(LRCol% - ULCol%, HorLineTop$) + URCorner$ + Edge$; '³ ³ or º º LOCATE ULRow% + 1, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; IF Title$ <> "" THEN 'ÃÄÄÄ´ or ÇÄÄĶ 'made cross bar if there is a title LOCATE ULRow% + 2, ULCol%, 0 PRINT Edge$ + LeftSide$ + STRING$(LRCol% - ULCol%, 196) + RightSide$ + Edge$; ELSEIF Title$ = "" THEN LOCATE ULRow% + 2, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; END IF '³ ³ or º º FOR Print.Box% = 1 TO (LRRow% - ULRow%) - 3 LOCATE ULRow% + Print.Box% + 2, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; NEXT 'ÀÄÄÄÙ or ÈÍÍͼ LOCATE LRRow%, ULCol%, 0 PRINT Edge$ + LLCorner$ + STRING$(LRCol% - ULCol%, HorLineBot$) + LRCorner$ + Edge$; IF Title$ <> "" THEN LOCATE TitleRow%, TitleCol%, 0 COLOR TitColrFG%, TitColrBG% PRINT Title$; END IF END SUB SUB EditSix (Row%, Col%, RCol%, Text$, TextType$, TextLen%, CCode%) 'I downloaded this from CompuServe in the mid-eighties. I found 'a bad error at line 56 which I corrected by adding "+ 1". 'Row% = the screen row 'Col% = the screen column 'RCol% = the right far column 'Text$ = the text that is sent and returned from the edit line 'TextType$ = the type of accepted text in string form ' Example: TextType$ = ".,0123456789". If Text$Type$ = "" ' then characters 32 to 254 are accepted. 'TextLen% = the length of the Text$ to be edit 'Ccode% = returned positive number of the key that was used ' to exit the edit call CONST BACKSPACE = 8, TABKEY = 9, ENTER = 13, DELWORD = 20, ESC = 27 CONST DELALL = 25, DOWN = -80, home = -71, UP = -72, PgUp = -73 CONST LEFT = -75, RIGHT = -77, ENDKEY = -79, PgDn = -81, INS = -82 CONST DEL = -83, WORDLEFT = -115, WORDRIGHT = -116 CONST CONTROLEND = -117, CONTROLHOME = -119 CONST F1 = -59, F2 = -60, F3 = -61, F4 = -62, F5 = -63 CONST F6 = -64, F7 = -65, F8 = -66, F9 = -67, F10 = -68 LOCATE Row%, Col%: COLOR 15, 0: PRINT SPACE$(TextLen%); TText$ = LEFT$(Text$ + STRING$(TextLen%, 32), TextLen%) CPos = LEN(Text$) + 1 TRUE = 1 Insert = 0 DO IF Insert THEN Insert = -1 LOCATE , , 1, 4, 7 ELSEIF NOT Insert THEN Insert = 0 LOCATE , , 1, 6, 7 END IF LLen = RCol% - Col% NRow% = CINT(TextLen% / LLen + .5) Cr = CPos \ LLen + 1 IF Cr > 1 THEN Cp = (CPos MOD (Cr - 1) * LLen) IF Cp = 0 THEN Cr = Cr - 1 Cp = LLen END IF ELSE Cp = CPos END IF R = Row% FOR x = 1 TO NRow% LOCATE R, Col%: PRINT MID$(TText$, x * LLen - LLen + 1, LLen); R = R + 1 IF CPos >= TextLen% + 1 THEN 'added + 1 to code CPos = 1 END IF NEXT LOCATE Row% + Cr - 1, Col% + Cp - 1 DO i$ = INKEY$ LOOP UNTIL LEN(i$) IF LEN(i$) = 1 THEN KeyC = ASC(i$) ELSE KeyC = -ASC(RIGHT$(i$, 1)) END IF SELECT CASE KeyC CASE 32 TO 254 IF INSTR(TextType$, i$) = 0 AND TextType$ <> "" THEN ELSE IF CPos <= TextLen% AND Insert THEN LOCATE , , 1, 4, 7 TText$ = LEFT$(TText$, CPos - 1) + i$ + MID$(TText$, CPos, TextLen% - CPos) CPos = CPos + 1 END IF IF CPos <= TextLen% AND NOT Insert THEN MID$(TText$, CPos, 1) = i$ CPos = CPos + 1 END IF END IF CASE BACKSPACE IF CPos > 1 THEN CPos = CPos - 1 TText$ = LEFT$(TText$, CPos - 1) + MID$(TText$, CPos + 1, TextLen% - CPos) + " " END IF CASE DEL TText$ = LEFT$(TText$, CPos - 1) + MID$(TText$, CPos + 1, TextLen% - CPos) + " " CASE DELALL TText$ = STRING$(TextLen%, 32) CPos = 1 CASE ENDKEY FOR xx = TextLen% TO 1 STEP -1 IF MID$(TText$, xx, 1) > CHR$(32) THEN CPos = xx + 1 EXIT FOR END IF NEXT CASE CONTROLEND, CONTROLHOME, ESC, PgDn, PgUp, TABKEY, F1, F2, F3, F4, F5, F6, F7, F8, F9, F10, UP, DOWN CCode% = KeyC EXIT SUB CASE ENTER Cr = (CPos / LLen + .5) CPos = Cr * LLen + 1 IF CPos > TextLen% THEN GOTO ExitRoutine END IF CASE home CPos = 1 CASE INS Insert = NOT Insert CASE LEFT IF CPos > 1 THEN CPos = CPos - 1 END IF CASE RIGHT IF CPos < TextLen% THEN CPos = CPos + 1 END IF CASE ELSE END SELECT LOOP WHILE TRUE ExitRoutine: CCode% = ABS(KeyC) Text$ = RTRIM$(TText$) END SUB FUNCTION Exist% (Spec$) STATIC DIM DTA AS STRING * 44 'This is DOS' work area 'Used by CALL Interrupt DIM LocalSpec AS STRING * 80 'Using a fixed-length string 'supports both QB and PDS LocalSpec$ = Spec$ + CHR$(0) 'Add a CHR$(0) for DOS Exist% = -1 'Assume the file is present Regs.ax = &H1A00 'Assign DTA service Regs.dx = VARPTR(DTA) 'Show DOS where to place it CALL Interrupt(&H21, Regs, Regs) Regs.ax = &H4E00 'Find first matching file Regs.cx = 39 'Any file attribute okay Regs.dx = VARPTR(LocalSpec) CALL Interrupt(&H21, Regs, Regs) 'See if there's a match IF Regs.flags AND 1 THEN 'If the Carry flag is set Exist% = 0 ' there were no matches END IF END FUNCTION SUB LongMenu (SM$(), LM$(), ULRowSM%, ULColSM%, LRRowSM%, LRColSM%, SMColrFG%, SMColrBG%, SMHiLiteFG%, SMHiLiteBG%, FKey$, MaxNum%, Selection%, ExitCode%, CurrentRow%) ' +---------------------------------------------------------------------+ ' | SUB LongMenu | ' +---------------------------------------------------------------------+ ' | The SUB LongMenu was rewritten by Don Smith on 08/01/2005. It is | ' | Public Domain FreeWare. LongMenu is a one-column menu with a | ' | block cursor. To move the cursor, use: , , | ' | , , , , , , | ' | or . SUB is 169 lines long not counting REM (') lines. | ' | | ' | This is a special rewrite of the SUB LongMenu to include both | ' | DOS filenames and long WindowXP filenames. | ' +--------------+------------------------------------------------------+ ' | SM$() | These are menu items which should be REDIMed in | ' | LM$() | the main program. | ' +--------------+------------------------------------------------------+ ' | ULRowSM% | (U)Upper (L)left (R)row to place (L)long (M)menu. | ' +--------------+------------------------------------------------------+ ' | ULColSM% | (U)Upper (L)left (C)column to place (L)long (M)menu. | ' +--------------+------------------------------------------------------+ ' | LRRowSM% | (L)Lower (R)right (R)row to place (L)long (M)menu. | ' +--------------+------------------------------------------------------+ ' | LRColSM% | (L)Lower (R)right (C)column to place (L)long (M)menu | ' +--------------+------------------------------------------------------+ ' | SMColrFG% | (L)Long (M)menu (F)fore (G)ground color. [0-15] | ' +--------------+------------------------------------------------------+ ' | SMColrBG% | (L)Long (M)menu (B)back (G)ground color. [0-15] | ' +--------------+------------------------------------------------------+ ' | SMHiLiteFG% | (L)Long (M)menu Hilite (F)fore (G)ground color.[0-15]| '+--------------+-------------------------------------------------------+ ' | SMHiLiteBG% | (L)Long (M)menu Hilite (B)back (G)ground color.[0-15]| ' +--------------+------------------------------------------------------+ ' | FKey$ | FKey$ is set to reflect to keys. | ' | | ExitCode% is set by programs as follows: | ' | | is ExitCode% = 1 TO is ExitCode% = 10 | ' | | | ' | | Example how to set in main program: | ' | | ---------------------------------- | ' | | Example: FKey$ = "150". This means that | ' | | and are "turned on" such that if the user | ' | | presses one of these keys, the program will | ' | | exit with the appropriate ExitCode% number. By | ' | | the way, the "0" in FKey$ = "150" is used for | ' | | , and if is pressed, the SUB will exit | ' | | with ExitCode% = 10. Also read ExitCode% below. | ' +--------------+------------------------------------------------------+ ' | MaxNum% | The maximum number of menu items. | ' +--------------+------------------------------------------------------+ ' | Selection% | The selection which the cursor is resting on. | ' | | In main program, set Selection% = 1 | ' +--------------+------------------------------------------------------+ ' | CurrentRow% | The current row the cursor is resting on. | ' | | In main program, set CurrentRow% = ULRowSM% | ' +--------------+------------------------------------------------------+ ' | ExitCode% | The ExitCode% is a unique number set by the | ' | | programmer. The SUB LongMenu will exit the SUB on | ' | | three occasions, when the user presses: , | ' | | , , , or . In the main program | ' | | just below the SUB, you must write the code to take | ' | | care of these key presses. The ExitCode% may be | ' | | any number the programmer wishes. In most cases, | ' | | I prefer to use the same number as the unique | ' | | number set by the CVI command. Below find | ' | | the double DO:LOOP and Hit% = CVI(Hit$ + CHR$(0)) | ' | | | ' | | do.loop: | ' | | DO | ' | | DO | ' | | Hit$ = INKEY$ | ' | | LOOP UNTIL LEN(Hit$) > 0 | ' | | Hit% = CVI(Hit$ + CHR$(0)) | ' | | - - - - - - - - | ' | | (more code here) | ' | | - - - - - - - - | ' | | LOOP | ' | | | ' | | This double DO:LOOP sets up the special CVI | ' | | numbers; if fact, just about any key or key | ' | | combination may be trapped using the CVI code. | ' | | See KEYCODE.BAS program below. | ' | | | ' | | For the key numbers, I prefer to use | ' | | ExitCode% 1-10; this is easier than using hugh | ' | | CVI numbers like 15103 . | ' | | | ' | | I like to use the double DO:LOOP (see above), | ' | | followed by a series of IFs and ELSEIFs. | ' | | If you would like to use a special key, like | ' | | Q (4096) for example, the attached | ' | | KEYCODE.BAS will give you the CVI numbers you | ' | | need for your program. In this case Q | ' | | would be set up like this: | ' | | | ' | | (This is inside the SUB) | ' | | DO | ' | | DO | ' | | Hit$ = INKEY$ | ' | | LOOP UNTIL LEN(Hit$) > 0 | ' | | Hit% = CVI(Hit$ + CHR$(0)) | ' | | IF Hit% = 27 THEN ' | ' | | ExitCode% = 27 | ' | | ELSEIF Hit% = 4096 THEN ' Q | ' | | ExitCode% = 4096 | ' | | END IF | ' | | LOOP | ' | | | ' | | Once the SUB is exited, the code would look | ' | | something like this: | ' | | | ' | | CALL LongMenu(- - - - -stuff goes here- - - - -) | ' | | | ' | | IF ExitCode% = 27 THEN ' | ' | | LOCATE , , 1, 6, 7: END | ' | | ELSEIF ExitCode% = 4096 THEN ' Q | ' | | COLOR 15, 2: CLS | ' | | PRINT "Help Screen" | ' | | DO: LOOP WHILE INKEY$ = "" | ' | | END IF | ' | | | ' | | The CVI numbers used in the SUB LongMenu are: | ' | | -------------------------------------------- | ' | | Hit% = 18176 | ' | | Hit% = 20224 | ' | | Hit% = 20480 | ' | | Hit% = 20736 | ' | | Hit% = 19712 | ' | | Hit% = 18432 | ' | | Hit% = 18688 | ' | | Hit% = 19200 | ' | | Hit% = 65-90 Letters To | ' | | Hit% = 48-57 Numbers <0> To <9> | ' | | | ' | | Use KEYCODE.BAS program below to find the CVI | ' | | code for keys you need for your program. | ' | | | ' +--------------+------------------------------------------------------+ ' | Use KEYCODE.BAS below to find out what the CVI numbers will be | ' | for keys you wish to trap. | ' +---------------------------------------------------------------------+ ' | ' KeyCode.Bas - By Don Smith. FreeWare and Public Domain Program. | ' | ' | ' | ' +-------------------------------------------------------------+ | ' | ' | Note: To reach the extended ASCII characters 127 to 255, | | ' | ' | press down on the key, and while pressed down, | | ' | ' | type in the number on your keypad, not the numbers | | ' | ' | above then keys. | | ' | ' +-------------------------------------------------------------+ | ' | | ' | COLOR 15, 1: CLS | ' | Top1$ = "Press a key and the KeyCode% value will be displayed." | ' | Top2$ = "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" | ' | Top3$ = "(Press To Quit" | ' | COLOR 15, 1 | ' | LOCATE 2, 15: PRINT Top1$ | ' | LOCATE 3, 15: PRINT Top2$ | ' | COLOR 11, 1 | ' | LOCATE 4, 30, 0: PRINT Top3$ | ' | PRINT : PRINT | ' | COLOR 14, 1 | ' | DO | ' | DO | ' | Hit$ = INKEY$ | ' | IF Hit$ = CHR$(27) THEN | ' | PRINT | ' | LOCATE , 10: COLOR 15, 1: PRINT STRING$(62, "-"); | ' | PRINT | ' | LOCATE , 34: COLOR 11, 1: PRINT "Program Ends"; | ' | PRINT : PRINT | ' | END | ' | END IF | ' | LOOP UNTIL Hit$ <> "" | ' | Hit% = CVI(Hit$ + CHR$(0)) | ' | Key$ = STR$(Hit%) | ' | IF Hit% < 256 THEN | ' | LOCATE , 32, 0 | ' | PRINT Hit$ + SPACE$(9) + "= " + Key$ | ' | ELSEIF Hit% > 255 THEN | ' | LOCATE , 21, 0 | ' | PRINT "Extended Key" + SPACE$(9) + "= " + Key$; "" | ' | END IF | ' | LOOP | ' +---------------------------------------------------------------------+ SetPage% = LRRowSM% - ULRowSM% + 1 IF Selection% = 1 THEN Foxy% = 0 ELSEIF Selection% > 1 THEN Foxy% = Selection% - (CurrentRow% - ULRowSM%) - 1 END IF subtop: COLOR SMColrFG%, SMColrBG% FOR BringItems% = ULRowSM% TO LRRowSM% Foxy% = Foxy% + 1 LOCATE BringItems%, ULColSM%, 0 COLOR SMColrFG%, SMColrBG% PRINT SPACE$(14) + "³" + SPACE$(59) IF Foxy% <= MaxNum% THEN LOCATE BringItems%, ULColSM%, 0 LenSpc% = LEN(SM$(Foxy%) + SPACE$(18 - LEN(SM$(Foxy%))) + LM$(Foxy%)) PRINT SM$(Foxy%) + SPACE$(14 - LEN(SM$(Foxy%))) + "³" + SPACE$(2) + LM$(Foxy%) + SPACE$(74 - LenSpc%) END IF NEXT Foxy% = Foxy% - (LRRowSM% - ULRowSM%) - 1 LOCATE CurrentRow%, ULColSM%, 0 COLOR SMHiLiteFG%, SMHiLiteBG% PRINT SM$(Selection%) do.loop: DO DO Hit$ = INKEY$ LOOP UNTIL LEN(Hit$) > 0 Hit% = CVI(Hit$ + CHR$(0)) LOCATE CurrentRow%, ULColSM%, 0 COLOR SMColrFG%, SMColrBG% PRINT SM$(Selection%) IF Hit% = 27 THEN ' ExitCode% = 27 EXIT SUB ELSEIF Hit% = 13 THEN ' ExitCode% = 13 EXIT SUB ELSEIF Hit% = 18176 THEN ' Selection% = 1 Foxy% = 0 CurrentRow% = ULRowSM% GOTO subtop ELSEIF Hit% = 20224 THEN ' Selection% = MaxNum% GOSUB end.james ELSEIF Hit% = 20480 THEN ' IF Selection% = MaxNum% THEN LOCATE CurrentRow%, ULColSM%, 0 COLOR SMHiLiteFG%, SMHiLiteBG% PRINT SM$(Selection%) GOTO do.loop END IF Selection% = Selection% + 1 SetCurrSel% = Selection% IF CurrentRow% > LRRowSM% - 1 THEN CurrentRow% = LRRowSM% Foxy% = Foxy% + 1 GOTO subtop END IF IF CurrentRow% <= LRRowSM% AND Selection% <= MaxNum% THEN CurrentRow% = CurrentRow% + 1 ELSEIF Selection% > MaxNum% THEN Selection% = MaxNum% END IF ELSEIF Hit% = 20736 OR Hit% = 19712 THEN ' Foxy% = Selection% + (LRRowSM% - CurrentRow%) SetCurrSel% = Selection% TempRow% = CurrentRow% Selection% = Selection% + SetPage% IF Selection% >= MaxNum% THEN Selection% = MaxNum% CurrentRow% = TempRow% + (MaxNum% - SetCurrSel%) IF CurrentRow% > LRRowSM% THEN CurrentRow% = LRRowSM% END IF Foxy% = Selection% - SetPage% + (LRRowSM% - CurrentRow%) GOTO subtop GOTO do.loop END IF GOTO subtop ELSEIF Hit% = 18432 THEN ' Selection% = Selection% - 1 IF CurrentRow% > ULRowSM% THEN CurrentRow% = CurrentRow% - 1 ELSEIF CurrentRow% = ULRowSM% THEN CurrentRow% = ULRowSM% IF Selection% >= 1 THEN Foxy% = Foxy% - 1 GOTO subtop ELSE Selection% = 1 END IF END IF ELSEIF Hit% = 18688 OR Hit% = 19200 THEN ' Selection% = Selection% - SetPage% Foxy% = Selection% - SetPage% + (LRRowSM% - CurrentRow%) IF Selection% < 1 THEN Selection% = 1 Foxy% = 0 CurrentRow% = ULRowSM% GOTO subtop END IF IF Foxy% < 0 THEN Selection% = 1 CurrentRow% = ULRowSM% Foxy% = 0 END IF GOTO subtop 'PRESS: Letters A - Z (or a - z), Numbers 0 - 9, ' Exclamation , or Underline <_>. ELSEIF Hit% > 64 AND Hit% < 91 OR Hit% > 96 AND Hit% < 123 OR Hit% > 47 AND Hit% < 58 OR Hit% = 33 OR Hit% = 95 THEN IF Hit% > 96 AND Hit% < 123 THEN Hit% = Hit% - 32 END IF FOR XYZ% = 1 TO MaxNum% Letr$ = LEFT$(SM$(XYZ%), 1) IF XYZ% = MaxNum% AND ASC(Letr$) <> Hit% THEN GOTO subtop ELSEIF ASC(Letr$) = Hit% THEN EXIT FOR END IF NEXT TryLetters% = TryLetters% + 1 FOR ZZZ% = TryLetters% TO MaxNum% FindLetr$ = LEFT$(SM$(ZZZ%), 1) IF ASC(FindLetr$) = Hit% THEN Selection% = ZZZ% TryLetters% = ZZZ% CurrentRow% = ULRowSM% Foxy% = Selection% - 1 IF ZZZ% = MaxNum% THEN Selection% = MaxNum% TryLetters% = 0 END IF GOTO subtop END IF IF ZZZ% = MaxNum% THEN ZZZ% = 0 END IF NEXT ELSEIF Hit% > 15103 AND Hit% < 17409 THEN 'F1 - F10 IdentKey$ = STR$(((Hit% - 15104) \ 256) + 1) IdentKey$ = LTRIM$(RTRIM$(IdentKey$)) IF IdentKey$ = "10" THEN IdentKey$ = "0" END IF IF INSTR(FKey$, IdentKey$) > 0 THEN IF IdentKey$ = "0" THEN ExitCode% = 10 EXIT SUB ELSE ExitCode% = VAL(IdentKey$) EXIT SUB END IF END IF END IF LOCATE CurrentRow%, ULColSM%, 0 COLOR SMHiLiteFG%, SMHiLiteBG% PRINT SM$(Selection%) LOOP end.james: IF CurrentRow% < 24 THEN Foxy% = Selection% + (LRRowSM% - CurrentRow%) TempRow% = CurrentRow% - 1 Selection% = Selection% + SetPage% IF Selection% >= MaxNum% THEN Selection% = MaxNum% CurrentRow% = TempRow% + (MaxNum% - SetCurrSel%) IF CurrentRow% > LRRowSM% THEN CurrentRow% = LRRowSM% END IF Foxy% = Selection% - SetPage% + (LRRowSM% - CurrentRow%) GOTO subtop END IF ELSE CurrentRow% = LRRowSM% Selection% = MaxNum% Foxy% = MaxNum% - (LRRowSM% - ULRowSM%) - 1 GOTO subtop END IF END SUB DEFSNG A-Z FUNCTION NewWord$ STATIC CONST vowel$ = "aeiou" CONST consonant$ = "bcdfghklmnpqrstvwxyz" syllables% = Rand& MOD 3 + 1 FOR i% = 1 TO syllables% t$ = t$ + MID$(consonant$, RandInteger%(1, 21), 1) IF i% = 1 THEN t$ = UCASE$(t$) END IF t$ = t$ + MID$(vowel$, RandInteger%(1, 5), 1) NEXT i% IF Rand& MOD 2 THEN t$ = t$ + MID$(consonant$, RandInteger%(1, 21), 1) END IF NewWord$ = t$ t$ = "" END FUNCTION SUB ProcesX (a$) STATIC FOR i% = 1 TO LEN(a$) byte% = ASC(MID$(a$, i%, 1)) XOR RandInteger%(0, 255) MID$(a$, i%, 1) = CHR$(byte%) NEXT i% END SUB FUNCTION Rand& STATIC 'Get the pointers into the table: i% = R&(98) j% = R&(99) 'Subtract the two table values: t& = R&(i%) - R&(j%) 'Adjust result if less then zero: IF t& < 0 THEN t& = t& + 1000000000 END IF 'Replace table entry with new random number R&(i%) = t& 'Decrement first index, keeping in range 1 through 55: IF i% > 1 THEN R&(98) = i% - 1 ELSE R&(98) = 55 END IF 'Decrment second index, keeping in range 1 through 55: IF j% > 1 THEN R&(99) = j% - 1 ELSE R&(99) = 55 END IF 'Use last random number to index into shuffle table: i% = R&(100) MOD 42 + 56 'Grab random from table at current random number: R&(100) = R&(i%) 'Put new calculated random into table: R&(i%) = t& 'Return the random number grabbed from the table: Rand& = R&(100) END FUNCTION FUNCTION RandInteger% (a%, b%) RandInteger% = a% + (Rand& MOD (b% - a% + 1)) END FUNCTION SUB RandShuffle (key$) STATIC 'Form 97-character string, with key$ as part of it: k$ = LEFT$("Abra Ca Da Bra" + key$ + SPACE$(83), 97) 'Use each character to seed table: FOR i% = 1 TO 97 R&(i%) = ASC(MID$(k$, i%, 1)) * 8171717 + i% * 997& NEXT i% 'Preserve string space: k$ = "" 'Initialize pointers into table: i% = 97 j% = 12 'Randomize the table to get it warmed up: FOR k% = 1 TO 997 'Subtract entries pointed to by i% and j%: R&(i%) = R&(i%) - R&(j%) 'Adjust result if less than zero: IF R&(i%) < 0 THEN R&(i%) = R&(i%) + 1000000000 END IF 'Decrement first index, keeping in range of 1 through 97: IF i% > 1 THEN i% = i% - 1 ELSE i% = 97 END IF 'Decrement second index, keeping in range of 1 through 97: IF j% > 1 THEN j% = j% - 1 ELSE j% = 97 END IF NEXT k% 'Initialize pointers for use by Rand& function: R&(98) = 55 R&(99) = 24 'Initialize pointer for shuffle table lookup by Rand& function: R&(100) = 77 END SUB DEFINT A-Z SUB SaveRestScrn (ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) '+----------------------------------------------------------------------+ '| SUB written by Don Smith on 03/25/02 - Public Domain FreeWare. | '| No need to name Don as the author. EMail: smithdonb@earthlink.net | '+----------------------------------------------------------------------+ '+------------------+---------------------------------------------------+ '| (1) ReadLine$() | Just include these when calling the program. | '| (2) ReadColr%() | As an example, glance above at the SUB | '+------------------+---------------------------------------------------+ '| THE PROGRAMMER MUST SET NUMBERS 3 TO 9 BEFORE CALLING THIS SUB -> | '+----------------------------------------------------------------------+ '| (Note: The "SR" below means "Save" Or "Restore") | '+------------------+---------------------------------------------------+ '| (3) SR.UL.Row% | Screen to save or restore at upper left row. | '| (4) SR.UL.Col% | Screen to save or restore at upper left column. | '| (5) SR.LR.Row% | Screen to save or restore at lower right row. | '| (6) SR.LR.Col% | Screen to save or restore at lower right column.| '| +---------------------------------------------------+ '| | SPECIAL CAUTION: | '| | --------------- | '| | When you call the SUB to restore the underlying | '| | screen, use MUST use the same row and column | '| | numbers as you used when you first called the | '| | SUB to save the screen. To save the entire | '| | screen, use: | '| | | '| | SR.UL.Row% = 1 | '| | SR.UL.Col% = 1 | '| | SR.LR.Row% = 25 | '| | SR.LR.Col% = 80 | '+------------------+---------------------------------------------------+ '| (7) SaveOrRest% | SaveOrRest% = 1 (1 means save the screen) | '| | SaveOrRest% = 2 (2 means restore the screen) | '+------------------+----------+----------------------------------------+ '| (8) REDIM ReadLine$(25) | The REDIM for ReadLine$ and ReadColr% | '| REDIM ReadColr%(25, 80) | must be placed in the main program | '| | before calling the SUB. The 25 and 80 | '| | reflects a screen of 25 lines and 80 | '| | columns. You may use smaller amounts | '| | of memory if you do not need all 25 | '| | lines and 80 columns. | '+-----------------------------+----------------------------------------+ '| (9) ERASE ReadLine$ | Reclaim memory after calling the SUB | '| ERASE ReadColr% | to restore the screen. Use REDIM and | '| | ERASE in main program please! | '+-----------------------------+----------------------------------------+ IF SR.LR.Col% > 80 THEN SR.LR.Col% = 80 END IF IF SR.LR.Row% > 25 THEN SR.LR.Row% = 25 END IF IF SaveOrRest% = 1 THEN GOSUB save.da.screen ELSEIF SaveOrRest% = 2 THEN GOSUB restore.da.screen END IF EXIT SUB save.da.screen: FOR ViewIt% = SR.UL.Row% TO SR.LR.Row% FOR Horizon% = SR.UL.Col% TO SR.LR.Col% ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) ReadColr%(ViewIt%, Horizon%) = SCREEN(ViewIt%, Horizon%, 1) NEXT NEXT RETURN restore.da.screen: FOR FindRow% = SR.UL.Row% TO SR.LR.Row% FOR ScrnCol% = SR.UL.Col% TO SR.LR.Col% LOCATE FindRow%, ScrnCol%, 0, 0, 0 OneColr% = ReadColr%(FindRow%, ScrnCol%) FGScrnColr% = OneColr% MOD 16 BGScrnColr% = OneColr% \ 16 COLOR FGScrnColr%, BGScrnColr% PRINT MID$(ReadLine$(FindRow%), ScrnCol% - (SR.UL.Col% - 1)); NEXT NEXT RETURN END SUB SUB TrueView (FileName$, ULRow%, ULCol%, LRRow%, LRCol%, FGColr%, BGColr%, TBColrFG%, TBColrBG%, TBNumColrFG%, TBNumColrBG%, EOFColrFG%, EOFColrBG%) ' +----------------------------------------------------------------------+ ' | | ' | ð T R U E V I E W F I L E B R O W S E R ð | ' | - - - - - - - - - - - - - - - - - - - | ' | (This SUB can be very easily made into a stand alone program.) | ' +----------------------------------------------------------------------+ ' +----------------------------------------------------------------------+ ' | TrueView.Bas written by Don Smith on 05/20/2002. Written for | ' | QuickBASIC 4.5. No special libraries are needed. Released to | ' | the public domain. Programmers need not give my name. They can | ' | even change the name of the program. | ' | | ' | If this is to be made into a stand alone program, programmers | ' | will probably want to include an error screen using: | ' | ON ERROR GOTO errorhandler | ' |----------------------------------------------------------------------| ' | Information about the author: | ' | ---------------------------- | ' | Hello, my name is Don Smith and I am a retired Math/History/Spanish | ' | teacher currently residing in Orange County, California. | ' | | ' | My email is: smithdonb@earthlink.net | ' |----------------------------------------------------------------------| ' | TrueView is an ASCII text browser. TrueView is so written as to | ' | avoid having to rely on Dimensioning or Redimensioning. It | ' | continuously keeps track of where the top line is, and it | ' | continuously opens and closes the COMMAND$ file. There is never | ' | a need to worry about how much memory is needed. | ' |----------------------------------------------------------------------| ' | If is pressed, the screen is saved and moved up | ' | or down and only one line is brought in to complete the screen. | ' | and work also to move text up or down. If | ' | is pressed then the next screen page is presented. | ' |----------------------------------------------------------------------| ' | Trueview probably shouldn't be used for huge files longer than | ' | 10000 lines. Beyond 10000 lines, it slows down a tad. I have a | ' | Pentium 4 2.65 CPU Ghz Gateway computer running under WindowsXP, | ' | and Trueview really did not lag in reading a 10,000 line file. I | ' | tried it out, however, on my old Pentium-S 166 Mhz computer, and | ' | it did lag a tiny bit, but not badly. ' |----------------------------------------------------------------------| ' | Compiling: | ' | | ' | BC: TrueView /e 'use /e for errors | ' | | ' | LINK: TrueView /noe | ' | LIB : BCom45 | ' | | ' +----------------------------------------------------------------------+ ' +---------------+------------------------------------------------------+ ' | FileName$ | The ASCII text file to view. As a stand alone | ' | | program, FileName$ will be a give as a command | ' | | line parameter and will look like this at the top | ' | | of the program: FileName$ = COMMAND$ | ' |---------------+------------------------------------------------------| ' | ULRow% | Upper left row to place text. | ' |---------------+------------------------------------------------------| ' | ULCol% | Upper left column to place text. | ' |---------------+------------------------------------------------------| ' | LRRow% | Lower right row to place text. | ' |---------------+------------------------------------------------------| ' | LRCol% | Lower right column to place text. | ' |---------------+------------------------------------------------------| ' | FGColr% | Foreground color of text (0-15). | ' |---------------+------------------------------------------------------| ' | BGColr% | Back ground color of text (0-7). | ' |---------------+------------------------------------------------------| ' | TBColrFG% | Foreground color of top/bottom strips (0-15). | ' |---------------+------------------------------------------------------| ' | TBColrBG% | Background color of the top/bottom strips (0-7). | ' |---------------+------------------------------------------------------| ' | TBNumColrFG% | Foreground color of top line numbering (0-15). | ' |---------------+------------------------------------------------------| ' | TBNumColrBG% | Background color of bottom line numbering (0-7). | ' |---------------+------------------------------------------------------| ' | EOFColrFG% | Foreground color of "End Of File" message (0-15). | ' |---------------+------------------------------------------------------| ' | EOFColrBG% | Background color of "End Of File" message (0-7). | ' +---------------+------------------------------------------------------+ FileName$ = RTRIM$(LTRIM$(FileName$)) SR.UL.Row% = ULRow% 'Upper left row to save/restore screen. SR.UL.Col% = ULCol% 'Upper left column to save/restore screen SR.LR.Row% = LRRow% 'Lower right row to save/restore screen. SR.LR.Col% = LRCol% 'Lower right column to save/restore screen. ' Temp.UL.Row% = SR.UL.Row% + 1 Temp.LR.Row% = SR.LR.Row% - 1 DownUp& = 1 ' 'next 9 lines set up the beginning screen and then closes OpeningScreen% = LRRow% - ULRow% + 1 OPEN FileName$ FOR INPUT AS #1 COLOR FGColr%, BGColr%: CLS FOR BringIt% = 1 TO OpeningScreen% IF EOF(1) THEN EXIT FOR LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) LOCATE BringIt% + ULRow% - 1, ULCol%, 0, 0, 0 LOCATE , , 0, 0, 0 PRINT M$; CheckLines% = CheckLines% + 1 NEXT IF CheckLines% < 23 THEN EndYes% = 1: EndPg% = 1: EndOfPage% = 1 END IF GOSUB paint.top.bottom CLOSE #1 loopdeloop: DO IF DownUp& <= 0 THEN DownUp& = 1 END IF COLOR TBNumColrFG%, TBNumColrBG% LOCATE ULRow% - 1, 71, 0, 0, 0: PRINT " "; LOCATE ULRow% - 1, 71, 0, 0, 0: PRINT STR$(DownUp&); LOCATE LRRow% + 1, 71, 0, 0, 0: PRINT " "; LOCATE LRRow% + 1, 71, 0, 0, 0: PRINT STR$(DownUp& + (LRRow% - ULRow%)); COLOR FGColr%, BGColr% DO TheKey$ = INKEY$ LOOP UNTIL LEN(TheKey$) > 0 TheKey% = CVI(TheKey$ + CHR$(0)) IF TheKey% = 20480 OR TheKey% = 19712 THEN ' IF Booboo% = 1 OR CheckLines% < 23 THEN GOTO loopdeloop ELSE EndYes% = 0: EndPg% = 0 FileEnd% = 0 END IF DnAr% = 1 UpAr% = 0 IF EndOfFile% <> 1 THEN SR.UL.Row% = Temp.UL.Row% SR.LR.Row% = Temp.LR.Row% + 1 GOSUB save.true.screen CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR DnIt& = 1 TO DownUp& + (LRRow% - ULRow% + 1) IF EOF(1) THEN EndOfFile% = 1 EndPg% = 1 CLOSE #1 EXIT FOR END IF LINE INPUT #1, Fox$ IF RTRIM$(LTRIM$(Fox$)) = CHR$(12) THEN Fox$ = SPACE$(80) Fox$ = LEFT$(Fox$, 80) NEXT IF EndOfFile% <> 1 THEN IF NOT EOF(1) THEN LOCATE LRRow%, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE LRRow%, ULCol%, 0, 0, 0 PRINT Fox$; ELSEIF EOF(1) THEN LOCATE LRRow%, ULCol%, 0, 0, 0 COLOR EOFColrFG%, EOFColrBG% SOUND 150, 2 PRINT STRING$(35, "-") + "End Of File" + STRING$(34, "-"); END IF END IF DownUp& = DownUp& + 1 ELSEIF EndOfFile% = 1 THEN GOTO loopdeloop END IF ELSEIF TheKey% = 20736 THEN ' IF EndPg% = 1 OR EndYes% = 1 OR EndOfPage% = 1 OR CheckLines% < 23 THEN GOTO loopdeloop END IF IF FileEnd% = 0 THEN CLOSE #1 FileEnd% = 1 END IF PgDn& = DownUp& + LRRow% - ULRow% CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR PgDn1& = 1 TO PgDn& IF EOF(1) THEN FileEnd% = 1 CLOSE #1 EXIT FOR END IF LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) NEXT DownUp& = DownUp& + (LRRow% - ULRow% + 1) FOR PgDn2% = 1 TO (LRRow% - ULRow% + 1) IF EndPg% = 0 THEN IF EOF(1) THEN FileEnd% = 1 CLOSE #1 GOSUB da.end.james EXIT FOR END IF END IF LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) LOCATE PgDn2% + 1, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE PgDn2% + 1, ULCol%, 0, 0, 0 PRINT M$; NEXT ELSEIF TheKey% = 18688 THEN ' Booboo% = 0 EndYes% = 0: EndPg% = 0 IF PgDn& > LRRow% - ULRow% + 1 OR DownUp& > (LRRow% - ULRow% + 1) THEN PgUp& = DownUp& - (LRRow% - ULRow% + 1) CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR PgUp1& = 1 TO PgUp& - 1 LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) NEXT FOR PgUp2& = 1 TO (LRRow% - ULRow% + 1) LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) LOCATE PgUp2& + 1, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE PgUp2& + 1, ULCol%, 0, 0, 0 PRINT M$; NEXT DownUp& = DownUp& - (LRRow% - ULRow% + 1) ELSE GOSUB home.james END IF ELSEIF TheKey% = 18432 OR TheKey% = 19200 THEN ' Booboo% = 0 EndYes% = 0: EndPg% = 0 EndOfFile% = 0 EndPg% = 0 FileEnd% = 0 DnAr% = 0 UpAr% = 1 DownUp& = DownUp& - 1 IF DownUp& = 1 THEN GOSUB home.james ELSEIF DownUp& > 1 THEN SR.UL.Row% = Temp.UL.Row% - 1 SR.LR.Row% = Temp.LR.Row% GOSUB save.true.screen CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR UpIt& = 1 TO DownUp& LINE INPUT #1, M$ NEXT IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) LOCATE ULRow%, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE ULRow%, ULCol%, 0, 0, 0 PRINT M$; END IF ELSEIF TheKey% = 18176 THEN ' EndYes% = 0: EndPg% = 0: Booboo% = 0 GOSUB home.james ELSEIF TheKey% = 20224 THEN ' EndPg% = 0: Booboo% = 0 IF EndYes% = 0 THEN GOSUB da.end.james END IF ELSEIF TheKey% = 27 THEN CLOSE #1 EXIT SUB END IF LOOP paint.top.bottom: ' +---------------------------------------------------------------------+ ' | When this subroutine is called, the top and bottom | ' | rows are displayed. | ' +---------------------------------------------------------------------+ COLOR TBColrFG%, TBColrBG% LOCATE ULRow% - 1, 1, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE ULRow% - 1, 31, 0, 0, 0 PRINT CHR$(240) + " TrueView Program " + CHR$(240); LOCATE ULRow% - 1, 62, 0, 0, 0 PRINT "Top Line:"; LOCATE ULRow% - 1, 2, 0, 0, 0 PRINT "File: " + ComFile$ LOCATE LRRow% + 1, 1, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE LRRow% + 1, 2, 0, 0, 0 PRINT "EXIT: MOVE: "; LOCATE LRRow% + 1, 21, 0, 0, 0 PRINT "<" + CHR$(24) + "> <" + CHR$(25) + "> "; LOCATE LRRow% + 1, 59, 0, 0, 0 PRINT "Bottom Line: "; COLOR FGColr%, BGColr% RETURN da.end.james: ' +---------------------------------------------------------------------+ ' | when the end of a file is reached, the | ' | program branches to this procedure: | ' +---------------------------------------------------------------------+ EndYes% = 1: EndPg% = 1 COLOR TBColrFG%, TBColrBG% LOCATE 1, 22, 0, 0, 0: PRINT "- Please Wait -" + SPACE$(14) DownUp& = 0 EndOfFile% = 0 FileEnd% = 0 CountLines& = 0 CLOSE #1 OPEN FileName$ FOR INPUT AS #1 DO LINE INPUT #1, ThrowAway$ IF EOF(1) THEN EXIT DO CountLines& = CountLines& + 1 LOOP UNTIL EOF(1) CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR LastScrn& = 1 TO CountLines& + 1 - (LRRow% - ULRow% + 1) IF EOF(1) THEN EXIT FOR END IF LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) ManyLines& = ManyLines& + 1 COLOR TBColrFG%, TBColrBG% LOCATE 1, 40, 0, 0, 0: PRINT "Loading:"; LOCATE 1, 49, 0, 0, 0: PRINT RTRIM$(LTRIM$(STR$(ManyLines&))); NEXT GOSUB paint.top.bottom FOR TheLastScrn% = ULRow% TO LRRow% IF EOF(1) THEN EXIT FOR END IF LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) COLOR FGColr%, BGColr% LOCATE TheLastScrn%, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LOCATE TheLastScrn%, ULCol%, 0, 0, 0 PRINT M$; NEXT CLOSE #1 DownUp& = CountLines& - (LRRow% - ULRow% + 1) + 1 COLOR TBColrFG%, TBColrBG% LOCATE 1, 22, 0, 0, 0: PRINT " - TrueView Program - "; COLOR FGColr%, BGColr% ManyLines& = 0 RETURN home.james: ' +---------------------------------------------------------------------+ ' | when the top of a file is reached, the program | ' | branches to this subroutine: | ' +---------------------------------------------------------------------+ CLOSE #1 OPEN FileName$ FOR INPUT AS #1 FOR HomePage% = ULRow% TO LRRow% IF EOF(1) THEN EXIT FOR END IF LOCATE HomePage%, ULCol%, 0, 0, 0 PRINT SPACE$(LRCol% - ULCol% + 1); LINE INPUT #1, M$ IF RTRIM$(LTRIM$(M$)) = CHR$(12) THEN M$ = SPACE$(80) M$ = LEFT$(M$, 80) LOCATE HomePage%, ULCol%, 0, 0, 0 PRINT M$; NEXT DownUp& = 1 GOSUB paint.top.bottom RETURN save.true.screen: ' +---------------------------------------------------------------------+ ' | When the program asks for GOSUB save.screen, the following | ' | six lines saves the screen from row 2 to row 24: | ' +---------------------------------------------------------------------+ REDIM ReadLine$(25) FOR ViewIt% = SR.UL.Row% TO SR.LR.Row% FOR Horizon% = SR.UL.Col% TO SR.LR.Col% ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) NEXT NEXT restore.true.screen: ' +---------------------------------------------------------------------+ ' |This subroutine restores the above saved screen, except the saved | ' |screen is moved either up or down. If the down arrow is pressed, then| ' |DnAr% = 1 and the saved screen is moved up one place and a new line | ' |is brought in and displayed at row 24. If the up arrow is pressed, | ' |then UpAr% = 1 and the saved screen is moved down one row and a new | ' |line is displayed at row 2, just under the top linebar. | ' +---------------------------------------------------------------------+ IF DnAr% = 1 THEN StartSite% = SR.UL.Row% - 1 StopSite% = SR.LR.Row% - 1 ELSEIF UpAr% = 1 THEN StartSite% = SR.UL.Row% + 1 StopSite% = SR.LR.Row% + 1 END IF FOR FindRow% = StartSite% TO StopSite% LOCATE FindRow%, SR.UL.Col%, 0, 0, 0 PRINT SPACE$(LRRow% - ULRow% + 1); LOCATE FindRow%, SR.UL.Col%, 0, 0, 0 COLOR FGColr%, BGColr% IF DnAr% = 1 THEN PRINT ReadLine$(FindRow% + DnAr%); ELSEIF UpAr% = 1 THEN PRINT ReadLine$(FindRow% - UpAr%); END IF NEXT ERASE ReadLine$ RETURN END SUB