' +---------------------------------------------------------------------+ ' | | ' | - C a l e n d a r . B a s - | ' | | ' | | ' | Public Domain - FreeWare | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | Perfect Calendar Program | ' +---------------------------------------------------------------------+ ' | The Perfect Calendar program is a Public Domain, FreeWare program, | ' | written on 03/06/2002 by Don Smith. | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | - ABOUT THE AUTHOR - | ' +---------------------------------------------------------------------+ ' | | ' | Hello. My name is Don Smith and I am a retired thiry-year teacher | ' | of Math/History/Spanish residing in Orange County, California. I am | ' | also a former 6-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. | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | NOTE: This program requires two libraries to compile: | ' | ---- | ' | +----------------+-------------------------------------+ | ' | | 1. Pro.Lib | FULL MOON Libraries of Ethan Winer. | | ' | | 2. Pdq.Lib | http://www.ethanwiner.com | | ' | | | Email: ethan@ethanwiner.com | | ' | +----------------+-------------------------------------+ | ' | | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | BC: Calendar | ' | | ' | LINK: Calendar Cal1 /noe | ' | | ' | LIB: pro pdq | ' +---------------------------------------------------------------------+ '$DYNAMIC DEFINT A-Z DECLARE SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFor%, TitColrBak%, BoxColrFor%, BoxColrBak%, BoxStyle%, Shadow%, ClearColr%) DECLARE SUB Cal1 (MonoCode%) DECLARE SUB Calendar (IMonth, IDay, IYear, ULRow, ULCol, Colr1, Colr2, Action, OldColor) DECLARE SUB CheckStatus (Trial%, ErrExist%) DECLARE SUB EditString (EdW$, Row%, Col%, FCol%, LenStr%, TypeOfText$, Caps%, Colr%, FKey$, ExitCode%) DECLARE SUB FillScrn (ULRow, ULCol, LRRow, LRCol, Colr, Char, Page) DECLARE SUB QPrint0 (x$, Colr) DECLARE SUB SaveRestScrn (ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) DECLARE SUB SCMenu (Menu$(), Selection%, FGColr%, BGColr%, FGHiLite%, BGHiLite%, TopRow%, Col%, MaxItems%, LetrOrNum%, SingOrDoub%, FKey$, ClearScrn%, ExitCode%) DECLARE FUNCTION Exist% (FileName$) DECLARE FUNCTION FileSize& (FileName$) DECLARE FUNCTION LoadExec% (FirstName$, SecondFile$) DECLARE FUNCTION QPTrim$ (FileName$) DECLARE FUNCTION OneColor% (FG%, BG%) DECLARE FUNCTION Rand% (Hi%, Lo%) Selection% = 1 begin: IYear = VAL(QPTrim$(MID$(DATE$, 7, 4))) IMonth = VAL(QPTrim$(MID$(DATE$, 1, 2))) start: COLOR 15, 1: CLS GOSUB find.month IDay = VAL(QPTrim$(MID$(DATE$, 4, 2))) There = Exist%("yearfile.txt") IF There = 0 THEN IYear = VAL(QPTrim$(MID$(DATE$, 7, 4))) Year$ = STR$(IYear) GOSUB print.routine ELSE Lines = FileSize&("yearfile.txt") IF Lines < 3 THEN IYear = VAL(QPTrim$(MID$(DATE$, 7, 4))) Year$ = STR$(IYear) GOTO start2 END IF OPEN "yearfile.txt" FOR INPUT AS #5 DO LINE INPUT #5, SearchIn$ FOR SearchColon% = 1 TO LEN(SearchIn$) Colon$ = MID$(SearchIn$, SearchColon%, 1) IF Colon$ = CHR$(58) THEN FoundColon$ = MID$(SearchIn$, SearchColon% + 1, 7) FoundColon$ = QPTrim$(FoundColon$) Year$ = FoundColon$ CLOSE #5 EXIT DO END IF NEXT LOOP UNTIL EOF(5) CLOSE #5 END IF 'BLOAD "c:\dos\program\bsv\cal1.bsv" CALL Cal1(MonoCode%) start2: GOTO QPCName.list QPCName.list: DATA January, February, March, April, May, June DATA July, August, September, October, November, December 'IMonth ' Month - month (1 ... 12). Set by SUB editblnk 'IDay = 1 ' Year - 4 places (YYYY) 'IYear = VAL(QPTrim$(MID$(DATE$, 7, 4))) ' Day - the day to be highlighted ULRow = 9 ' ULRow, ULCol - upper left corner of calendar ULCol = 3 Colr1 = 79 ' Color1 - color to use for the calendar border frame Colr2 = 79 ' Color2 - color to use for the day names and numbers Action = 1 ' Action - indicates whether to show or clear ' the display: 1 = Action, 0 = clear OldColor = 15 CALL Calendar(IMonth, IDay, IYear, ULRow, ULCol, Colr1, Colr2, Action, OldColor) 'Selection% = 1 FGColr% = 0 BGColr% = 7 FGHiLite% = 15 BGHiLite% = 0 TopRow% = 5 Col% = 40 MaxItems% = 5 LetrOrNum% = 1 SingOrDoub% = 1 FKey$ = "1" ClearScrn% = 0 ExitCode% = 0 REDIM Menu$(MaxItems% + 1) Menu$(1) = "1. View Another Month" Menu$(2) = "2. See An Entire Year" Menu$(3) = "3. Print Out An Entire Year" Menu$(4) = "4. See Documentation" Menu$(5) = "5. Exit" 'Menu$(4) = "4. View Printed Out Year: " + Year$ CALL SCMenu(Menu$(), Selection%, FGColr%, BGColr%, FGHiLite%, BGHiLite%, TopRow%, Col%, MaxItems%, LetrOrNum%, SingOrDoub%, FKey$, ClearScrn%, ExitCode%) new.month: IF ExitCode% = 18176 THEN ' GOTO begin ELSEIF ExitCode% = 19200 THEN ' IMonth = IMonth - 1 IF IMonth = 0 THEN IMonth = 12 IYear = IYear - 1 END IF GOTO start ELSEIF ExitCode% = 19712 THEN ' IMonth = IMonth + 1 IF IMonth = 13 THEN IMonth = 1 IYear = IYear + 1 END IF GOTO start ELSEIF ExitCode% = 18688 THEN ' IYear = IYear + 1 IF IYear = 32001 THEN IYear = 32000 END IF GOTO start ELSEIF ExitCode% = 20736 THEN ' IYear = IYear - 1 IF IYear = -32001 THEN IYear = -32000 END IF GOTO start END IF DO IF ExitCode% = 1 THEN GOSUB smith.id GOTO start END IF IF ExitCode% = 27 THEN GOTO leave END IF OldSelection% = Selection% IF Selection% = 1 THEN CALL BoxBoy("Enter The Month Below:", 8, 36, 12, 66, 9, 40, 15, 1, 15, 1, 1, 1, 1000) LOCATE 11, 48 CALL MQPrint(STRING$(9, " "), 15) CurrMonth = IMonth CALL EditString(EdW$, 11, 48, 48, 9, "", 1, 15, "", ExitCode%) IF ExitCode% = 27 THEN 'BLOAD "c:\basic\bsv\cal1.bsv" CALL Cal1(MonoCode%) GOTO QPCName.list ' ELSEIF ExitCode% = 13 OR ExitCode% = 18 OR ExitCode% = 17 OR ExitCode% = 20480 THEN EdW$ = QPTrim$(EdW$) IF EdW$ = "" THEN EdW$ = CurrMonth$ END IF IMonth = 0 GOSUB find.month IF IMonth = 0 THEN CALL BoxBoy("", 15, 36, 18, 66, 1, 1, 1, 1, 15, 1, 1, 1, 1000) LOCATE 16, 39 CALL MQPrint("Unable to read your month.", 31) LOCATE 17, 39 CALL MQPrint("Please Try Again. Press ", 31) LOCATE 17, 64, 0: CALL MQPrint("Esc", 27) CALL QPSound(200, 2) DO NM$ = INKEY$ IF NM$ = CHR$(27) THEN IMonth = CurrMonth GOTO start END IF LOOP END IF CALL BoxBoy("Enter The Year:", 8, 36, 12, 66, 9, 40, 15, 1, 15, 1, 1, 1, 1000) LOCATE 11, 50: CALL MQPrint(" ", 15) LOCATE 11, 50: CALL MQPrint(QPTrim$(STR$(IYear)), 15) CALL QPSound(200, 2) CurrYear = IYear CALL EditString(EdW$, 11, 50, 50, 5, "-0123456789", 1, 15, "", ExitCode%) EdW$ = QPTrim$(EdW$) IF ExitCode% = 27 THEN 'BLOAD "c:\basic\bsv\cal1.bsv" CALL Cal1(MonoCode%) GOTO QPCName.list ' / ELSEIF ExitCode% = 13 OR ExitCode% = 18 OR ExitCode% = 17 THEN EdW$ = QPTrim$(EdW$) IF VAL(EdW$) = 0 THEN IYear = CurrYear GOTO start ELSEIF VAL(EdW$) > 32000 THEN GOSUB year.error ELSE IYear = VAL(QPTrim$(EdW$)) GOTO start END IF ELSEIF ExitCode% = 27 THEN ' GOTO leave END IF GOTO start ELSEIF ExitCode% = 27 THEN ' GOTO leave END IF ELSEIF Selection% = 2 THEN CurrMonth = IMonth KeepYear = IYear ChangeUp = 1 CALL BoxBoy("Give The Year Below =", 4, 36, 9, 66, 5, 40, 15, 1, 15, 1, 1, 1, 1000) LOCATE 8, 51: CALL MQPrint(" ", 15) PresentYear = IYear CALL EditString(EdW$, 8, 51, 51, 5, "-0123456789", 1, 15, "", ExitCode%) IF VAL(EdW$) = 0 THEN CALL BoxBoy("", 15, 36, 18, 66, 1, 1, 1, 1, 15, 1, 1, 1, 1000) LOCATE 16, 39 CALL MQPrint("Unable to read your year.", 31) LOCATE 17, 39 CALL MQPrint("Please Try Again. Press ", 31) LOCATE 17, 64, 0: CALL MQPrint("Esc", 27) CALL QPSound(200, 2) DO NY$ = INKEY$ IF NY$ = CHR$(27) THEN IMonth = CurrMonth IYear = KeepYear Selection% = OldSelection% GOTO start END IF LOOP ELSEIF VAL(EdW$) > 32000 THEN GOSUB year.error IYear = KeepYear IMonth = CurrMonth GOTO start ELSEIF ExitCode% = 27 THEN 'Esc GOTO start ' / ELSEIF ExitCode% = 13 OR ExitCode% = 18 OR ExitCode% = 17 THEN EdW$ = QPTrim$(EdW$) IF VAL(EdW$) = 0 THEN IYear = PresentYear GOTO start END IF IYear = VAL(EdW$) GOSUB print.routine CALL CheckStatus(1, ErrExist%) CALL CheckStatus(5, ErrExist%) IF ErrExist% > 0 THEN GOTO start ELSEIF ErrExist% <> 1 AND ErrExist% <> 5 THEN CALL CheckStatus(6, ErrExist%) IF ErrExist% = 6 THEN Selection = OldSelection GOTO start END IF SeeDoc% = LoadExec%("seebee.exe", "yearfile.txt") END IF IMonth = CurrMonth IYear = PresentYear GOTO start END IF ELSEIF Selection% = 3 THEN CALL CheckStatus(3, ErrExist%) CALL CheckStatus(4, ErrExist%) IF ErrExist% > 0 THEN GOTO start END IF KeepYear = IYear CurrMonth = IMonth OldSelection% = Selection% CALL BoxBoy("Give The Year Below -", 4, 36, 9, 66, 5, 40, 15, 1, 15, 1, 1, 1, 1000) LOCATE 8, 51: CALL MQPrint(" ", 15) CALL EditString(EdW$, 8, 51, 51, 5, "-0123456789", 1, 15, "", ExitCode%) IF VAL(EdW$) > 32000 THEN GOSUB year.error Selection = OldSelection GOTO start ELSEIF VAL(EdW$) = 0 THEN CALL BoxBoy("", 15, 36, 18, 66, 1, 1, 1, 1, 15, 1, 1, 1, 1000) LOCATE 16, 39 CALL MQPrint("Unable to read your year.", 31) LOCATE 17, 39 CALL MQPrint("Please Try Again. Press ", 31) LOCATE 17, 64, 0: CALL MQPrint("Esc", 27) CALL QPSound(200, 2) DO NY$ = INKEY$ IF NY$ = CHR$(27) THEN IMonth = CurrMonth IYear = KeepYear Selection = OldSelection GOTO start END IF LOOP ELSEIF InString$ = CHR$(27) THEN Selection = OldSelection GOTO start ' / ELSEIF ExitCode% = 13 OR ExitCode% = 18 OR ExitCode% = 17 THEN EdW$ = QPTrim$(EdW$) IYear = VAL(EdW$) Year$ = EdW$ END IF Title$ = "Print Out -" ULRow% = 12 ULCol% = 36 LRRow% = 18 LRCol% = 66 TitleRow% = 13 TitleCol% = 47 TitColrFor% = 15 TitColrBak% = 1 BoxColrFor% = 15 BoxColrBak% = 1 BoxStyle% = 1 Shadow% = 1 ClearColr% = 1000 CALL BoxBoy(Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFor%, TitColrBak%, BoxColrFor%, BoxColrBak%, BoxStyle%, Shadow%, ClearColr%) CALL QPSound(200, 2) REDIM PP$(MaxItems% + 1) PP$(1) = "1. Print To File" PP$(2) = "2. Print To Printer" PP$(3) = "3. Exit" OldSelection = Selection Selection% = 1 CALL SCMenu(PP$(), Selection%, 15, 1, 15, 0, 15, 43, 3, 1, 1, "", 0, ExitCode%) IF ExitCode% = 27 THEN Selection = OldSelection GOTO start ELSEIF Selection% = 1 THEN GOSUB print.routine CALL CheckStatus(1, ErrExist%) IF ErrExist% > 0 THEN Selection = OldSelection GOTO start END IF SeeNew% = LoadExec%("SeeBee.Exe", "YearFile.Txt") IYear = KeepYear Selection = OldSelection GOTO start ELSEIF Selection% = 2 THEN GOSUB print.routine CALL CheckStatus(3, ErrExist%) IF ErrExist% > 0 THEN Selection = OldSelection GOTO start ELSE PrnNow% = LoadExec%("PrintIt.Exe", "yearfile.txt") IYear = KeepYear Selection = OldSelection GOTO start END IF ELSEIF Selection% = 3 THEN IYear = KeepYear Selection = OldSelection GOTO start END IF GOTO start 'ELSEIF Selection = 4 THEN ' CALL CheckStatus(1, ErrExist%) ' CALL CheckStatus(5, ErrExist%) ' IF ErrExist% > 0 THEN ' GOTO start ' ELSEIF ErrExist% <> 1 AND ErrExist% <> 5 THEN ' CALL CheckStatus(6, ErrExist%) ' IF ErrExist% = 6 THEN ' Selection = OldSelection ' GOTO start ' END IF ' SeeDoc% = LoadExec%("seebee.exe", "yearfile.txt") ' GOTO start ' END IF ELSEIF Selection% = 4 THEN CALL CheckStatus(1, ErrExist%) CALL CheckStatus(2, ErrExist%) IF ErrExist% > 0 THEN GOTO start ELSE SeeDoc% = LoadExec%("seebee.exe", "calendar.doc") GOTO start END IF ELSEIF Selection% = 5 THEN GOTO leave END IF LOOP smith.id: COLOR 15, 0: CLS CALL Box0(7, 10, 16, 70, 1, 15) LOCATE 8, 13 CALL MQPrint("IDENTIFICATION OF AUTHOR. Hello! My name is Donald", 15) LOCATE 8, 13 CALL MQPrint("IDENTIFICATION OF AUTHOR", 14) LOCATE 9, 13 CALL MQPrint("Bernard Smith, and I am the author of the Perfect", 15) LOCATE 10, 13 CALL MQPrint("Calendar Program. I will not give my social security", 15) LOCATE 11, 13 CALL MQPrint("number, but for purposes of identification, my USMC", 15) LOCATE 12, 13 CALL MQPrint("serial number is 1672175. Today's date is 03/06/2002.", 15) LOCATE 13, 13 CALL MQPrint("The Perfect Calendar is Public Domain FreeWare.", 15) LOCATE 15, 21 CALL MQPrint("Press To Return To The Main Menu.", 15) LOCATE 15, 28: CALL MQPrint("Esc", 11) DO: LOOP UNTIL INKEY$ = CHR$(27) RETURN print.routine: COLOR 15, 0: CLS IMonth = 1 IDay = 1 ULRow = 1 ULCol = 3 Colr1 = 11 Colr2 = 15 Action = 1 OldColor = 15 CALL Calendar(1, IDay, IYear, ULRow, 3, Colr1, Colr2, Action, OldColor) CALL Calendar(2, IDay, IYear, ULRow, 28, Colr1, Colr2, Action, OldColor) CALL Calendar(3, IDay, IYear, ULRow, 53, Colr1, Colr2, Action, OldColor) ULRow = 14 CALL Calendar(4, IDay, IYear, ULRow, 3, Colr1, Colr2, Action, OldColor) CALL Calendar(5, IDay, IYear, ULRow, 28, Colr1, Colr2, Action, OldColor) CALL Calendar(6, IDay, IYear, ULRow, 53, Colr1, Colr2, Action, OldColor) REDIM ReadLine$(25): REDIM ReadColr%(25, 80) CALL SaveRestScrn(ReadLine$(), ReadColr(), 1, 1, 25, 78, 1) OPEN "YearFile.Txt" FOR OUTPUT AS #2 StateYear$ = QPTrim(STR$(IYear)) lenYear% = LEN(StateYear$) Spacer% = 14 - lenYear% PRINT #2, CHR$(12) PRINT #2, SPACE$(70) PRINT #2, SPACE$(23) + CHR$(201) + STRING$(29, CHR$(205)) + CHR$(187) PRINT #2, SPACE$(23) + CHR$(186) + " Year: " + StateYear$ + SPACE$(Spacer%) + CHR$(186) PRINT #2, SPACE$(23) + CHR$(200) + STRING$(29, CHR$(205)) + CHR$(188) PRINT #2, SPACE$(70) PRINT #2, SPACE$(70) FOR xyz = 1 TO 25 PRINT #2, ReadLine$(xyz) NEXT ERASE ReadLine$: ERASE ReadColr% PRINT #2, SPACE$(70) Action = 1 IDay = 1 'IYear = 2002 Colr1 = 11 Colr2 = 15 ULRow = 1 OldColor = 15 COLOR 15, 0: CLS CALL Calendar(7, IDay, IYear, ULRow, 3, Colr1, Colr2, Action, OldColor) CALL Calendar(8, IDay, IYear, ULRow, 28, Colr1, Colr2, Action, OldColor) CALL Calendar(9, IDay, IYear, ULRow, 53, Colr1, Colr2, Action, OldColor) ULRow = 14 CALL Calendar(10, IDay, IYear, ULRow, 3, Colr1, Colr2, Action, OldColor) CALL Calendar(11, IDay, IYear, ULRow, 28, Colr1, Colr2, Action, OldColor) CALL Calendar(12, IDay, IYear, ULRow, 53, Colr1, Colr2, Action, OldColor) REDIM ReadLine$(25): REDIM ReadColr%(25, 80) CALL SaveRestScrn(ReadLine$(), ReadColr%(), 1, 1, 25, 78, 1) FOR abc = 1 TO 25 PRINT #2, ReadLine$(abc) NEXT PRINT #2, CHR$(12); CLOSE #2 ERASE ReadLine$: ERASE ReadColr% RETURN find.month: EdW$ = QPTrim$(EdW$) IF EdW$ = "JANUARY" OR EdW$ = "JAN" THEN IMonth = 1 ELSEIF EdW$ = "FEBRUARY" OR EdW$ = "FEB" THEN IMonth = 2 ELSEIF EdW$ = "MARCH" OR EdW$ = "MAR" THEN IMonth = 3 ELSEIF EdW$ = "APRIL" OR EdW$ = "APR" THEN IMonth = 4 ELSEIF EdW$ = "MAY" OR EdW$ = "MAY" THEN IMonth = 5 ELSEIF EdW$ = "JUNE" OR EdW$ = "JUN" THEN IMonth = 6 ELSEIF EdW$ = "JULY" OR EdW$ = "JUL" THEN IMonth = 7 ELSEIF EdW$ = "AUGUST" OR EdW$ = "AUG" THEN IMonth = 8 ELSEIF EdW$ = "SEPTEMBER" OR EdW$ = "SEP" THEN IMonth = 9 ELSEIF EdW$ = "OCTOBER" OR EdW$ = "OCT" THEN IMonth = 10 ELSEIF EdW$ = "NOVEMBER" OR EdW$ = "NOV" THEN IMonth = 11 ELSEIF EdW$ = "DECEMBER" OR EdW$ = "DEC" THEN IMonth = 12 END IF RETURN year.error: CALL BoxBoy("***Error***", 9, 18, 15, 58, 10, 33, 15, 5, 15, 5, 1, 1, 1000) LOCATE 10, 33, 0 CALL MQPrint("***Error***", 94) LOCATE 12, 23 CALL MQPrint("Number can be no higher then 32000", 95) LOCATE 14, 25 CALL MQPrint("- Press Any Key To Continue -", 95) LOCATE 12, 52: CALL MQPrint("32000", 94) CALL Chime(6) DO: LOOP WHILE INKEY$ = "" RETURN leave: COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END REM $STATIC SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFor%, TitColrBak%, BoxColrFor%, BoxColrBak%, BoxStyle%, Shadow%, ClearColr%) ' ' '+---------------------------------------------------------------------+ '| SUB written by Don Smith on February 20, 2002. Declared Public | '| Domain FreeWare. Other programmers may use this SUB without | '| naming me as the author. Don's EMail: smithdonb@earthlink.net | '| | '+-------------+-------------------------------------------------------+ '| 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. | '|-------------+-------------------------------------------------------| '| TitleCol% | The column to place the title. | '|-------------+-------------------------------------------------------| '| TitColrFor% | The foreground color of the title. | '|-------------+-------------------------------------------------------| '| TitColrBak% | The back ground color of the title. | '|-------------+-------------------------------------------------------| '| BoxColrFor% | The foreground color of the box itself. | '|-------------+-------------------------------------------------------| '| BoxColrBak% | The back ground color of the box. | '+-------------+-------------------------------------------------------+ '| Style% | Style% equals 1 - Single line around box | '| | Style% equals 2 - Double 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: | '| | ---- | '| | When a shadow is used, the underlying text will | '| | be saved and printed with COLOR 8, 0 (very dim). | | '| | This causes the shadow to look like a real shadow. | '+-------------+-------------------------------------------------------+ '| ClearColr% | What color (0-7) to clear screen before making box. | '| | To disable this feature, use ClearColr% = 1000 | '+-------------+-------------------------------------------------------+ ' ' IF ClearColr% <> 1000 THEN COLOR , ClearColr%: CLS END IF TitColr = OneColor%(TitColrFor%, TitColrBak%) BoxColr = OneColor%(BoxColrFor%, BoxColrBak%) make.box: IF BoxStyle% = 1 THEN 'Single Line ULCorner$ = CHR$(218) URCorner$ = CHR$(191) HorLine$ = 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) HorLine$ = CHR$(205) LeftSide$ = CHR$(199) RightSide$ = CHR$(182) VertLine$ = CHR$(186) LLCorner$ = CHR$(200) LRCorner$ = CHR$(188) END IF IF Shadow% = 1 THEN REDIM ReadLine$(25) FOR ViewIt% = ULRow% + 1 TO LRRow% + 1 FOR Horizon% = ULCol% + 2 TO LRCol% + 2 ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) NEXT NEXT COLOR 8, 0 FOR Print.Shadow% = 1 TO LRRow% - ULRow% + 1 LOCATE ULRow% + Print.Shadow%, ULCol% + 2 CALL MQPrint(SPACE$(LRCol% - ULCol% + 4), 8) NEXT FOR Scratch% = ULRow% + 1 TO LRRow% + 1 LOCATE Scratch%, ULCol% + 2 CALL MQPrint(ReadLine$(Scratch%), 8) NEXT ELSEIF Shadow% = 2 THEN REDIM ReadLine$(25) FOR ViewIt% = ULRow% + 1 TO LRRow% + 1 FOR Horizon% = ULCol% - 2 TO LRCol% - 2 ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) NEXT NEXT COLOR 8, 0 FOR Print.Shadow% = 1 TO LRRow% - ULRow% + 1 LOCATE ULRow% + Print.Shadow%, ULCol% - 2 CALL MQPrint(SPACE$(LRCol% - ULCol% + 4), 8) NEXT FOR Scratch% = ULRow% + 1 TO LRRow% + 1 LOCATE Scratch%, ULCol% - 2 CALL MQPrint(ReadLine$(Scratch%), 8) NEXT END IF Title.Length% = LEN(Title$) COLOR BoxColrFor%, BoxColrBak% 'Ŀ or ͻ LOCATE ULRow%, ULCol% CALL MQPrint(" " + ULCorner$ + STRING$(LRCol% - ULCol%, HorLine$) + URCorner$ + " ", BoxColr) ' or LOCATE ULRow% + 1, ULCol% CALL MQPrint(" " + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + " ", BoxColr) IF Title$ <> "" THEN 'Ĵ or Ķ 'made cross bar if there is a title LOCATE ULRow% + 2, ULCol% CALL MQPrint(" " + LeftSide$ + STRING$(LRCol% - ULCol%, 196) + RightSide$ + " ", BoxColr) ELSEIF Title$ = "" THEN LOCATE ULRow% + 2, ULCol% CALL MQPrint(" " + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + " ", BoxColr) END IF ' or FOR Print.Box = 1 TO (LRRow% - ULRow%) - 3 LOCATE ULRow% + Print.Box% + 2, ULCol% CALL MQPrint(" " + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + " ", BoxColr) NEXT ' or ͼ LOCATE LRRow%, ULCol% CALL MQPrint(" " + LLCorner$ + STRING$(LRCol% - ULCol%, HorLine$) + LRCorner$ + " ", BoxColr) LOCATE TitleRow%, TitleCol% 'COLOR TitColrFor%, TitColrBak% CALL MQPrint(Title$, TitColr) END SUB SUB Calendar (IMonth, IDay, IYear, ULRow, ULCol, Colr1, Colr2, Action, OldColor) STATIC ' +----------------------------------------------------------------------+ ' | Displaying and removing the calendar is accomplished by the same | ' | call, the only difference is the contents of the switch variable | ' | Action (Action = 1 to show calendar, Action = 0 to remove it). | ' | | ' | Month - month (1 ... 12) | ' | Year - 4 places (YYYY) | ' | Day - the day to be highlighted | ' | ULRow, ULCol - upper left corner of calendar | ' | Action - indicates whether to show or clear the display | ' | 1 = Action, 0 = clear | ' | Colr1 - color to use for the calendar border frame | ' | Colr2 - color to use for the day names and numbers | ' | OldColor = Day hi-light color ' +----------------------------------------------------------------------+ Month = IMonth: Day = IDay: Year = IYear 'preserve incoming ' variables ULRow1 = ULRow: LRRow = ULRow + 11 'frame parameters ULCol1 = ULCol: LRCol = ULCol + 23 V = CSRLIN: H = POS(0) 'save the cursor 'CLS : PRINT ULRow1, ULCol1, LRRow, LRCol: END IF Action THEN REDIM ScrnArray%(2500) 'ScrnSave0 ULRow1, ULCol1, LRRow, LRCol, a(0) 'save screen 'CALL ScrnSave0(ULRow1, ULCol1, LRRow, LRCol, SEG ScrnArray(1)) CALL ScrnSave0(1, 1, 25, 80, SEG ScrnArray%(0)) ELSE 'ScrnRest0 ULRow1, ULCol1, LRRow, LRCol, a(0) 'restore old screen 'CALL ScrnRest0(ULRow1, ULCol1, LRRow, LRCol, SEG ScrnArray%(1)) 'CALL ScrnRest0(1, 1, 25, 80, SEG ScrnArray%(0)) 'ERASE a ERASE ScrnArray% GOTO QPCDone END IF GOSUB QPCFrame 'draw frame GOSUB QPCCalendar 'calculate and display calendar GOTO QPCDone 'all done QPCCalendar: GOSUB QPCMonth.Name GOSUB QPCCalc Mon.First! = NextMon.First! LOCATE ULRow1 + 1, ULCol1 + 3, 0 '+space$(4), Colr2 QPrint0 " " + LEFT$(Moname$ + SPACE$(10), 10) + STR$(Year), Colr2 ULRow1 = ULRow1 + 3 LOCATE ULRow1, ULCol1 + 1 QPrint0 " Su Mo Tu We Th Fr Sa", Colr2 'Germany: " Mo Di Mi Do Fr Sa So" DayOfWeek = NextMon.First! - INT(NextMon.First! / 7) * 7 + 1 'Germany: w/o +1 ULRow1 = ULRow1 + 2 LOCATE ULRow1, ULCol1 + 1 IF DayOfWeek <> 7 THEN QPrint0 SPACE$(DayOfWeek * 3), Colr1 'Germany: * 4 LOCATE , POS(0) + DayOfWeek * 3 END IF Month = Month - INT(Month / 12.1) * 12 + 1 IF Month = 1 THEN Year = Year + 1 GOSUB QPCCalc 'OldColor = (Colr2 AND 112) / 16 + (Colr2 AND 15) * 16 AND 127 'OldColor = 15 FOR x = 1 TO NextMon.First! - Mon.First! QPrint0 " ", Colr2 LOCATE , POS(0) + 1 IF x = Day THEN SWAP Colr2, OldColor 'the day to highlight QPrint0 RIGHT$(" " + STR$(x), 2), Colr2 IF x = Day THEN SWAP Colr2, OldColor LOCATE , POS(0) + 2 DayOfWeek = DayOfWeek + 1 IF INT(DayOfWeek / 7) = DayOfWeek / 7 THEN 'new line for next week ULRow1 = ULRow1 + 1 LOCATE ULRow1, ULCol1 + 1 END IF NEXT RETURN QPCCalc: 'calculate calendar Temp1 = Month + 13 Temp2 = Year - 1 IF Month > 2 THEN Temp1 = Month + 1 Temp2 = Year END IF NextMon.First! = INT(365.25 * Temp2) - 693975 + INT(30.6 * Temp1) RETURN QPCMonth.Name: RESTORE QPCName.list FOR M = 1 TO Month READ Moname$ NEXT M RETURN QPCFrame: LOCATE ULRow1, ULCol1 QPrint0 "" + STRING$(22, "") + "", Colr1 LOCATE ULRow1 + 1 QPrint0 "" + STRING$(22, " ") + "", Colr1 LOCATE ULRow1 + 2 QPrint0 "" + STRING$(22, "") + "", Colr1 LOCATE ULRow1 + 3 QPrint0 "" + STRING$(22, " ") + "", Colr1 LOCATE ULRow1 + 4 QPrint0 "" + STRING$(22, "") + "", Colr1 FOR x = ULRow1 + 5 TO ULRow1 + 10 LOCATE x QPrint0 "" + SPACE$(22) + "", Colr1 NEXT LOCATE ULRow1 + 11 QPrint0 "" + STRING$(22, "") + "", Colr1 RETURN QPCDone: LOCATE V, H, 0 'Alte Werte fr Screen-Restore wiederhFirst. END SUB SUB CheckStatus (Trial%, ErrExist%) STATIC ' ' Trial% = 1 check if SeeBee.Exe exists. ErrExist% = 1 ' Trial% = 2 check if Calender.Doc exists. ErrExist% = 2 ' Trial% = 3 check if PrintIt.Exe exists. ErrExist% = 3 ' Trial% = 5 check if YearFile.Txt exists. ErrExist% = 5 ' Trial% = 6 check how many lines YearFile.Txt has is less ' than 1 or 2 then Error ' ' ErrExist% = 0 Message1$ = "" IF Trial% = 1 THEN CheckDoc = Exist%("SeeBee.Exe") IF CheckDoc = 0 THEN Message1$ = "SeeBee.Exe" GOSUB show.error ErrExist% = 1 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 2 THEN CheckShowOff = Exist%("Calendar.Doc") IF CheckShowOff = 0 THEN Message1$ = "Calendar.Doc" GOSUB show.error ErrExist% = 2 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 3 THEN CheckPrintDoc = Exist%("PrintIt.Exe") IF CheckPrintDoc = 0 THEN Message1$ = "PrintIt.Exe" GOSUB show.error ErrExist% = 3 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 5 THEN CheckNamesDAT = Exist%("YearFile.Txt") IF CheckNamesDAT = 0 THEN Message1$ = " YEARFILE.TXT " + "File!" GOSUB show.error ErrExist% = 5 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 6 THEN LinesYFT = FileSize&("YearFile.Txt") IF LinesYFT < 3 THEN Message1$ = "Sorry, but YearFile.Txt is incomplete" GOSUB show.error ErrExist% = 6 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSE EXIT SUB END IF EXIT SUB show.error: CALL Box0(9, 20, 14, 60, 1, 15) CALL ClearScr0(10, 21, 13, 59, 15) LOCATE 12, 20: CALL MQPrint("" + STRING$(39, "" + ""), 15) LOCATE 10, 34: CALL MQPrint("<<< ERROR >>>", 12) IF Trial% = 1 OR Trial% = 2 OR Trial% = 3 THEN LOCATE 11, 27 ELSEIF Trial% = 4 OR Trial% = 5 THEN LOCATE 11, 23 END IF IF Trial% = 6 THEN LOCATE 11, 22 CALL MQPrint(Message1$, 15) ELSE CALL MQPrint("Unable To Find: " + Message1$, 15) END IF LOCATE 13, 30: CALL MQPrint("Press To Continue", 15) LOCATE 13, 37, 0, 0, 0: CALL MQPrint("ESC", 11) CALL QPSound(150, 2) RETURN END SUB SUB EditString (EdW$, Row%, Col%, FCol%, LenStr%, TypeOfText$, Caps%, Colr%, FKey$, ExitCode%) STATIC ' +---------------------------------------------------------------------+ ' | Explanation of SUB EditString : | ' | ----------------------------- | ' | EdW$ = The string to be edited. | ' | Row% = The row to begin the editing. | ' | Col% = The column to begin the editing. | ' | FCol% = The column of very first character to | ' | be edited. Should be the same as Col%. | ' | LenStr% = Length of the string to edit. | ' | TypeOfText$ = For all ASCII characers 32 to 255, TypeOfText = "" | ' | For numbers only, TypeOfText$ = "1234567890" | ' | For numbers with commas and decimals points, | ' | TypeOfText$ = ".,1234567890" | ' | For Yes or No answers, TypeOfText$ = "YNyn" | ' | Whatever is included within the parethesis | ' | is what will be accepted. | ' | Caps% = Capital letters enabled, Caps% =1 | ' | Colr% = Color of text must be one number representing | ' | both foreground and background. | ' | FKey$ = What F keys to enable. To enabled F keys 1, | ' | 5 and 10, FKey$ = "150" ("0" is F10). | ' | ExitCode% = 1 is F1 key | ' | ExitCode% = 2 is F2 key | ' | ExitCode% = 3 is F3 key | ' | ExitCode% = 4 is F4 key | ' | ExitCode% = 5 is F5 key | ' | ExitCode% = 6 is F6 key | ' | ExitCode% = 7 is F7 key | ' | ExitCode% = 8 is F8 key | ' | ExitCode% = 9 is F9 key | ' | ExitCode% = 10 is F10 key | ' | ExitCode% = 13 is ENTER key | ' | ExitCode% = 14 is Right Arrow -> | ' | ExitCode% = 15 is Left Arrow <- | ' | ExitCode% = 16 is Up Arrow | ' | ExitCode% = 17 is Down Arrow | ' | ExitCode% = 18 is TAB key | ' | ExitCode% = 27 is EXIT key | ' | | ' | Please include at the top of the routine DEFINT A-Z | ' +---------------------------------------------------------------------+ ' BkColr% = (Colr% AND 112) \ 16 ' begin.edit.line: DO LOCATE Row%, Col%, 1, 6, 7 DO EdW$ = INKEY$ LOOP UNTIL LEN(EdW$) > 0 SlamKey% = CVI(EdW$ + CHR$(0)) ' IF SlamKey% > 32 AND SlamKey% < 256 THEN 'chr$(33) to chr$255) IF TypeOfText$ = "" THEN GOSUB show.char ELSEIF TypeOfText$ <> "" THEN IF INSTR(TypeOfText$, EdW$) > 0 THEN GOSUB show.char END IF END IF ELSEIF SlamKey% = 27 THEN 'Esc Key ExitCode% = 27 GOSUB get.string GOTO leave.sub ELSEIF SlamKey% = 19712 THEN 'Right Arrow Col% = Col% + 1 IF Col% > FCol% + LenStr% - 1 THEN Col% = FCol% ELSE LOCATE Row%, Col%, 1, 6, 7 END IF ELSEIF SlamKey% = 19200 THEN 'Left Arrow Col% = Col% - 1 IF Col% = FCol% - 1 OR Col% < FCol% THEN Col% = FCol% + LenStr% - 1 END IF ELSEIF SlamKey% = 18432 THEN 'Up Arrow GOSUB get.string ExitCode% = 16 GOTO leave.sub ELSEIF SlamKey% = 20480 OR SlamKey% = 20736 THEN 'DnArrow/PgDn GOSUB get.string: ExitCode% = 17 GOTO leave.sub ELSEIF SlamKey% = 13 THEN 'Enter GOSUB get.string ExitCode% = 13 GOTO leave.sub ELSEIF SlamKey% = 9 THEN 'Tab GOSUB get.string ExitCode% = 18 GOTO leave.sub ELSEIF SlamKey% = 8 THEN 'Back Space Col% = Col% - 1 IF Col% = FCol% OR Col% < FCol% THEN Col% = FCol% END IF LOCATE Row%, Col%, 1, 6, 7 CALL MQPrint(" ", Colr%) ELSEIF SlamKey% = 32 THEN 'Space Bar CALL MQPrint(" ", BkColr%) GOSUB show.char ELSEIF SlamKey% = 21248 THEN 'Delete Key LenToSave = ((FCol% + LenStr%) - Col%) - 1 SaveScr$ = SPACE$(LenToSave) CALL ReadScrn0(Row%, Col% + 1, SaveScr$) LOCATE Row%, Col% CALL MQPrint(SaveScr$ + " ", Colr%) ELSEIF SlamKey% = 18176 THEN 'Home Key Col% = FCol% LOCATE Row%, Col%, 1, 6, 7 ELSEIF SlamKey% = 20224 THEN 'End Key GOSUB get.string Col% = FCol% + LEN(EdW$) - 1 LOCATE Row%, Col%, 1, 6, 7 ELSEIF SlamKey% = 25 THEN 'Ctrl-Y LOCATE Row%, FCol% WipeOut$ = SPACE$(LenStr%) CALL MQPrint(WipeOut$, Colr%) ELSEIF SlamKey% > 1503 OR SlamKey% < 17409 THEN 'F1 - F10 IdentKey$ = STR$(((SlamKey% - 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 GOSUB get.string GOTO leave.sub ELSE ExitCode% = VAL(IdentKey$) GOSUB get.string GOTO leave.sub END IF END IF END IF LOOP show.char: LOCATE Row%, Col% IF Caps% > 0 THEN CALL MQPrint(UCASE$(EdW$), Colr%) ELSEIF Caps% = 0 THEN CALL MQPrint(EdW$, Colr%) END IF Col% = Col% + 1 IF Col% = FCol% + LenStr% THEN Col% = FCol% RETURN END IF RETURN get.string: EditLine$ = SPACE$(LenStr%) CALL ReadScrn0(Row%, FCol%, EditLine$) EditLine$ = LTRIM$(RTRIM$(EditLine$)) EdW$ = EditLine$ RETURN leave.sub: END SUB FUNCTION Rand% (Hi%, Lo%) STATIC Rand% = RND * (Hi% - Lo%) + Lo% END FUNCTION SUB SaveRestScrn (ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) '+----------------------------------------------------------------------+ '| SUB written by Don Smith on 02/20/02 - Public Domain FreeWare. | '| No need to name Don as the author. EMail: smithdonb@earthlink.net | '+----------------------------------------------------------------------+ '+----------------------------------------------------------------------+ '| PROGRAM SETS NUMBERS 1 AND 2 -> | '+------------------+---------------------------------------------------+ '| (1) ReadLine$() | Program self reads data at each Row and Column | '+------------------+---------------------------------------------------+ '| (2) ReadColr%() | Program self reads color at each Row and Column | '+------------------+---------------------------------------------------+ '+----------------------------------------------------------------------+ '| THE PROGRAMMER MUST SET NUMBERS 3 TO 9 -> | '+----------------------------------------------------------------------+ '| (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. | '+------------------+---------------------------------------------------+ '| (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.screen ELSEIF SaveOrRest% = 2 THEN GOSUB restore.screen END IF EXIT SUB save.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.screen: FOR FindRow% = SR.UL.Row% TO SR.LR.Row% FOR ScrnCol% = SR.UL.Col% TO SR.LR.Col% LOCATE FindRow%, ScrnCol%, 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 SCMenu (Menu$(), Selection%, FGColr%, BGColr%, FGHiLite%, BGHiLite%, TopRow%, Col%, MaxItems%, LetrOrNum%, SingOrDoub%, FKey$, ClearScrn%, ExitCode%) ' ' +----------------------------------------------------------------------+ ' | SCMenu means "Southern California Menu" - Written by Don Smith | ' | on 02/20/02. SCMenu is declared Public Domain FreeWare. No need | ' | to name Don as the author. EMail: smithdonb@earthlink.net | ' +--------------+-------------------------------------------------------+ ' | Menu$() | REDIM in main program. Use MaxItems% + 1 for the | ' | | amount to be redimensioned. See code. Example with | ' | | a menu of 10 items => | ' | | | ' | | MaxItems% = 10 | ' | | REDIM Menu$(MaxItems% + 1) | ' | | | ' | | If you want to place a horizontal line in the menu | ' | | instead of text, use, for example: | ' | | | ' | | Menu$(4) = "-,20" | ' | | | ' | | The beginning dash means "use a line", followed by | ' | | a comma and then by a number. The number | ' | | represents the length of the line. If you use your | ' | | menu inside a box, such as the BoxBoy SUB, you | ' | | probable will also need to insert your own lines | ' | | so as to connect with the box. Two examples follow: | ' | | | ' | | Box with single line: | ' | | -------------------- | ' | | PRINT "" + STRING$(30, "") + "" | ' | | | ' | | Or if you prefer to use CHR$, then: | ' | | PRINT CHR$(195) + STRING$(30, CHR$(196)) + CHR$(180)| ' | | (Adjust the "30" to fit.) | ' | | | ' | | Box with double line: | ' | | -------------------- | ' | | PRINT "" + STRING$(30, "") + "" | ' | | | ' | | Or if you prefer to use CHR$, then: | ' | | PRINT CHR$(199) + STRING$(30, CHR$(196)) + CHR$(182)| ' | | | ' +--------------+-------------------------------------------------------+ ' | Selection% | The menu will start with the Selection that is | ' | | preset in the main program. When the user presses | ' | | , a number or a letter, the SUB will exit | ' | | reporting what the Selection was. The Selection | ' | | is always reported as a number. If you are using | ' | | numbers, use 1 to 10. See Example => | ' | | +----------------------------------------------+ | ' | | | Menu$(1) = "(1) Letters" (Selection% = 1) | | ' | | | . . . . . . . . . . | | ' | | | Menu$(9) = "(9) Word" (Selection% = 9) | | ' | | | Menu$(10)= "(0) Exit" (Selection% = 10)| | ' | | +----------------------------------------------+ | ' | | (Since there is no one key to represent | ' | | "10", the user will press "0" which gets | ' | | reported as "10".) | ' | | | ' | | The programmer is free to use numbers higher than | ' | | 10, but only the first 10 selections can be | ' | | pressed. After that, the user will need to use | ' | | and on a hi-lighted | ' | | item. | ' | +-------------------------------------------------------+ ' | | If Selection is a letter it will still be reported | ' | | as a number. Example: Letter "F" is Selection = 6) | ' +--------------+-------------------------------------------------------+ ' | FGColr% | Foreground Color (1-15) of the menu | ' +--------------+-------------------------------------------------------+ ' | BGColr% | Background color (1-7) of the menu | ' +--------------+-------------------------------------------------------+ ' | FGHiLite% | Foreground color (1-15) of the menu hi-lite item | ' +--------------+-------------------------------------------------------+ ' | BGHiLite% | Background color (1-7) of the menu hi-lite item | ' +--------------+-------------------------------------------------------+ ' | TopRow% | The very first row of the menu | ' +--------------+-------------------------------------------------------+ ' | Col | The column to place the menu (1-80) | ' +--------------+-------------------------------------------------------+ ' | MaxItems% | The number of menu items | ' +--------------+-------------------------------------------------------+ ' | LetrOrNum% | Tells the SUB if the menu is to be treated as a menu | ' | | with: (1) numbers, (2) letters or (3) neither. | ' | +-------------------------------------------------------+ ' | | LetrOrNum% = 1 | ' | | -------------- | ' | | The menu will be numbered from 1 to 10, and at | ' | | the press of a number, the SUB will exit with | ' | | the chosen Selection. If higher numbers are | ' | | required, that is not a problem. The only | ' | | limitation is that the the user will only | ' | | be able to press 1 to 0; for higher numbers, | ' | | and will be used. | ' | | The programmer may also choose to employ | ' | | LetrOrNum% = 3, below. | ' | +-------------------------------------------------------+ ' | | LetrOrNum% = 2 | ' | | -------------- | ' | | The menu will use letters from A to Y. In | ' | | this way, the menu may contain up to 25 items. | ' | | The letters get reported as numbers, 1 - 25. | ' | | For example: D = 4 and X = 24. The user has | ' | | the option of either pressing a letter, or | ' | | using and . | ' | +-------------------------------------------------------+ ' | | LetrOrNum% = 3 | ' | | -------------- | ' | | No numbers or numbers will be used. The user | ' | | will use and . | ' +--------------+-------------------------------------------------------+ ' | SingOrDoub% | SingOrDoub% = 1 The menu will be single spaced. | ' | | . . . . . . . . . . . | ' | | SingOrDoub% = 2 The menu will be double spaced. | ' +--------------+-------------------------------------------------------+ ' | FKey$ | FKey$ sets the F Keys from to . | ' | | To set and , use FKey$ = "157" | ' | | For , use "0". | ' | +-------------------------------------------------------+ ' | | Example -> FKey$ = "150" This sets , and | ' | | . The SUB will terminate with ExitCode% | ' | | equal to 1, 5 or 10. is the zero in the above | ' | | FKey$ = "150", and turns into 10 if the user presses | ' | | . To sum up, the FKey$ routine will permit the| ' | | use of F1-F10 as denoted in FKey$ string sequence. | ' | | When an key is pressed, the menu will exit | ' | | with an ExitCode% reporting a number of 1 to 10 | ' +--------------+-------------------------------------------------------+ ' | ClearScrn% | ClearScr% = 1 Clears the screen with FGColr% | ' | | and BGColr%. | ' | | ClearScr% = 0 Does NOT clear screen. | ' +--------------+-------------------------------------------------------+ ' | ExitCode% | When an key is pressed, the menu terminates | ' | | with ExitCode% reporting 1 to 10. The ExitCode% | ' | | also reports pressing as 27. | ' +--------------+-------------------------------------------------------+ ' make.menu: IF ClearScrn% = 1 THEN COLOR FGColr%, BGColr%: CLS ClearScrn% = 0 END IF COLOR FGColr%, BGColr% MainColr = OneColor%(FGColr%, BGColr%) HiLite = OneColor%(FGHiLite%, BGHiLite%) ZeusRow% = TopRow% FOR ItemPrint% = 1 TO MaxItems% LOCATE TopRow% + ItemPrint% - 1, Col%, 0 IF SingOrDoub% = 2 THEN TopRow% = TopRow% + 1 END IF IF LEFT$(Menu$(ItemPrint%), 1) = "-" THEN FOR Wof% = 1 TO LEN(Menu$(ItemPrint%)) Comma$ = MID$(Menu$(ItemPrint%), Wof%, 1) IF Comma$ = "," THEN ReadNum$ = MID$(Menu$(ItemPrint%), Wof% + 1, LEN(Menu$(ItemPrint%)) - Wof% + 1) EXIT FOR END IF NEXT COLOR FGColr%, BGColr% CALL MQPrint(STRING$(VAL(ReadNum$), CHR$(196)), MainColr) QuantLines% = QuantLines% + 1 ELSE CALL MQPrint(" " + Menu$(ItemPrint%) + " ", MainColr) MaxY% = MaxY% + 1 IF MaxY% = Selection% THEN SetSelection% = Selection% Selection% = Selection% + QuantLines% END IF END IF NEXT TopRow% = ZeusRow% COLOR FGHiLite%, BGHiLite% IF SingOrDoub% = 2 THEN LOCATE TopRow% + (Selection% * 2) - 2, Col% Row% = TopRow% + (Selection% * 2) - 2 ELSEIF SingOrDoub% = 1 THEN LOCATE TopRow% + Selection% - 1, Col% Row% = TopRow% + Selection% - 1 END IF CALL MQPrint(" " + Menu$(Selection%) + " ", HiLite) Down% = 0: Up% = 0 IF Selection% > 1 THEN DownUpNum% = SetSelection% ELSE DownUpNum% = 1 END IF begin.menu: DO DO KeyPress$ = INKEY$ KeyPress$ = UCASE$(KeyPress$) LOOP UNTIL LEN(KeyPress$) > 0 KeyPress% = CVI(KeyPress$ + CHR$(0)) ' +-------------------------------------------------------------------+ ' | The programmer may opt to use other keys besides letters, | ' | numbers, or . Examples: | ' | | ' | = 24064 = 21504 = 26624 | ' | = 24320 = 21760 = 26880 | ' | = 24576 = 22016 = 27136 | ' | (Add 256 each time) (Add 256 each time) (Add 256 each time) | ' | | ' | HOW TO USE HERE: | ' | --------------- | ' | ELSEIF KeyPress% = 24064 THEN ' | ' | ExitCode% = 11 ' At this point, the programmer | ' | ' may invent a number for | ' | ' ExitCode%, restricted only | ' | ' by not using 1-10 (F Keys) | ' | ' and 27 (Esc Key). | ' +-------------------------------------------------------------------+ ' IF KeyPress% = 19200 OR KeyPress% = 19712 OR KeyPress% = 18688 OR KeyPress% = 20736 OR KeyPress% = 18176 THEN ExitCode% = KeyPress% EXIT SUB ' Del> ELSEIF KeyPress% = 9 OR KeyPress% = 21248 OR KeyPress% = 20992 OR KeyPress% = 18176 OR KeyPress% = 20224 THEN GOTO begin.menu ELSEIF KeyPress% = 27 THEN ' ExitCode% = 27 EXIT SUB ELSEIF KeyPress% > 15103 AND KeyPress% < 17409 THEN 'F1 - F10 IdentKey$ = STR$(((KeyPress% - 15104) \ 256) + 1) IdentKey$ = QPTrim$(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 ELSEIF KeyPress% = 13 THEN ' ExitCode% = 0 Selection% = DownUpNum% EXIT SUB ELSEIF KeyPress% > 47 AND KeyPress% < 58 THEN 'a number pressed IF LetrOrNum% <> 1 THEN GOTO begin.menu END IF TempSelection% = Selection% Selection% = KeyPress% - 48 IF Selection% = 0 THEN Selection% = 10 END IF IF Selection% > MaxItems% THEN Selection% = TempSelection% GOTO begin.menu END IF ExitCode% = 0 EXIT SUB ELSEIF KeyPress% > 64 AND KeyPress% < 90 THEN 'A=65 Y=89 letter press. IF LetrOrNum% <> 2 THEN 'Lower case letters not GOTO begin.menu 'needed because UCASE$ END IF 'used at DO:LOOP TempSelection% = Selection% Selection% = KeyPress% - 64 IF Selection% > MaxItems% THEN Selection% = TempSelection% GOTO begin.menu END IF ExitCode% = 0 EXIT SUB ELSEIF KeyPress% = 20480 THEN ' Up% = 0 IF SingOrDoub% = 2 THEN Row% = Row% + 2 PrevRow% = Row% - 2 ELSE Row% = Row% + 1 PrevRow% = Row% - 1 END IF IF SingOrDoub% = 2 THEN IF Row% >= TopRow% + (MaxItems% * 2) THEN Row% = TopRow% PrevRow% = TopRow% + (MaxItems% * 2) - 2 END IF ELSE IF Row% >= TopRow% + MaxItems% THEN Row% = TopRow% PrevRow% = TopRow% + MaxItems% - 1 END IF END IF Down% = 1 ELSEIF KeyPress% = 18432 THEN ' Down% = 0 IF SingOrDoub% = 2 THEN Row% = Row% - 2 ELSE Row% = Row% - 1 END IF IF SingOrDoub% = 2 THEN LastRow% = Row% + 2 ELSE LastRow% = Row% + 1 END IF IF Row% < TopRow% THEN IF SingOrDoub% = 2 THEN Row% = TopRow% + (MaxItems% * 2) ELSE Row% = TopRow% + MaxItems% END IF LastRow% = TopRow% END IF Up% = 1 END IF IF Down% = 1 THEN 'Goin Down DownUpNum% = DownUpNum% + 1 IF DownUpNum% > MaxY% THEN DownUpNum% = 1 END IF COLOR FGColr%, BGColr% LOCATE PrevRow%, Col%, 0 CALL MQPrint(" " + Menu$(Selection%) + " ", MainColr) Selection% = Selection% + 1 IF SingOrDoub% = 2 THEN IF Selection% > MaxItems% THEN Selection% = 1 PrevRow% = TopRow% + (MaxItems% * 2) END IF ELSE IF Selection% > MaxItems% THEN Selection% = 1 PrevRow% = TopRow% + MaxItems% END IF END IF COLOR FGHiLite%, BGHiLite% 'Hi-Lite Color IF LEFT$(Menu$(Selection%), 1) = "-" THEN IF SingOrDoub% = 2 THEN Row% = Row% + 2 ELSE Row% = Row% + 1 END IF Selection% = Selection% + 1 END IF LOCATE Row%, Col%, 0 CALL MQPrint(" " + Menu$(Selection%) + " ", HiLite) ELSEIF Up% = 1 THEN 'Goin Up DownUpNum% = DownUpNum% - 1 IF DownUpNum% < 1 THEN DownUpNum% = MaxY% END IF COLOR FGColr%, BGColr% LOCATE LastRow%, Col%, 0 CALL MQPrint(" " + Menu$(Selection%) + " ", MainColr) Selection% = Selection% - 1 IF Selection% < 1 THEN IF SingOrDoub% = 2 THEN Selection% = MaxItems% Row% = TopRow% + (MaxItems% * 2) - 2 LastRow% = TopRow% ELSE Selection% = MaxItems% Row% = TopRow% + MaxItems% - 1 LastRow% = TopRow% END IF END IF IF LEFT$(Menu$(Selection%), 1) = "-" THEN IF SingOrDoub% = 2 THEN Row% = Row% - 2 ELSE Row% = Row% - 1 END IF Selection% = Selection% - 1 END IF COLOR FGHiLite%, BGHiLite% LOCATE Row%, Col%, 0 CALL MQPrint(" " + Menu$(Selection%) + " ", HiLite) ELSE PressKey% = 0: ExitCode% = 0: IdentKey$ = "" GOTO begin.menu END IF LOOP END SUB