ProfitPress Mega CDROM2 Shareware Freeware (MSDOS)(1992)(Eng)

home *** CD-ROM | disk | FTP | other *** search

/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / COMP8809.ZIP / SOURCE.EXE / SCREEN.BAS < prev next >

Wrap

BASIC Source File | 1988-04-21 | 58.6 KB | 1,780 lines

'┌───────────────────────────────────────────────────────────────────────────┐ '│ SCREEN.BAS │ '│ VERSION 1.0 │ '│ │ '│ │ '│ │ '│ This program allows the user to design screen formats and then │ '│ save them in ANSI or BASIC format files. │ '│ │ '│ Screen 0 - Working screen │ '│ Screen 1 - Commands screen │ '│ Screen 2 - Help screen & Status │ '│ Screen 3 - Directory screen & DOS Shell │ '└───────────────────────────────────────────────────────────────────────────┘ DEFINT A-Z ' All Integers GOSUB Init ' Set-up '┌─────────────────────────────── MAIN ───────────────────────────────────────┐ START: Xpos=POS : Ypos=CSRLIN ' Save current position CALL Update ' Status Line CALL Getkey(A$) IF A$=CHR$(27) THEN GOTO GOODBYE ' EXIT ? IF A$=CHR$(13) THEN A$=LastChar$ ' Repeat ? IF A$=CHR$(8) THEN CALL BackSpace ' BackSpace ? IF LEFT$(A$,1)<>CHR$(0) THEN ' Text ? CALL InsertText(A$) GOTO START END IF CALL Extkey(A$,K) ' Extended key code IF K=71 THEN CALL BeginofLine IF K=79 THEN CALL EndofLine IF K=73 THEN CALL ClearScreen IF K=77 THEN CALL MoveRight IF K=75 THEN CALL MoveLeft IF K=72 THEN CALL MoveUp IF K=80 THEN CALL MoveDown IF K=81 THEN CALL PageDn IF K=115 THEN CALL MidScreen IF K=116 THEN CALL MidScreen IF K=117 THEN CALL CtrlEnd IF K=119 THEN CALL CtrlHome IF K=59 THEN CALL F10 IF K=60 THEN CALL F2 IF K=61 THEN CALL Block IF K=63 THEN CALL F5 IF K=64 THEN CALL F6 IF K=65 THEN CALL F7 IF K=66 THEN CALL F8 IF K=67 THEN CALL F9 IF K=68 THEN CALL F10 GOTO START '└──────────────────────────────── END MAIN ──────────────────────────────────┘ ' Updates the current X & Y position SUB Update SHARED Xpos,Ypos COLOR 11,0 LOCATE 25,6,0 : ? Ypos; LOCATE 25,14,0 : ? Xpos; CALL RestoreCursor END SUB ' Update ' Getkey returns keypress in A$ SUB Getkey(A$) WHILE NOT INSTAT:WEND ' Wait for keypress A$=INKEY$ ' Into A$ END SUB ' Getkey ' Extkey K=extended code of A$ SUB Extkey(A$,K) K=ASC(MID$(A$,2)) ' K=EXT KEY CODE ' K=59-68 F1-F10 ' K=77 Right Arrow, 116 Ctrl ' K=75 Left Arrow, 115 Ctrl ' K=72 Up Arrow, 144 Ctrl ' K=80 Down Arrow, 150 Ctrl END SUB ' Extkey ' RestoreCursor Restores current cursor position and curent colors SUB RestoreCursor SHARED Ypos,Xpos,CurrentFore,CurrentBack LOCATE Ypos,Xpos,1,1,7 COLOR CurrentFore,CurrentBack END SUB ' RestoreCursor SUB ClearScreen SHARED WSmall(),WClearData() CALL OPENWINDOW(WSmall(),WClearData()) ' Open Clear Window LOCATE 12,26,0 COLOR 15,4 ?" Erase entire Screen ? (Y/N)"; ' Sure ? WHILE NOT INSTAT:WEND ' Wait for keypress A$=INKEY$ CALL CLOSEWINDOW(WSmall(),WClearData()) ' Close Window CALL RestoreCursor ' Restore Position IF UCASE$(A$) <> "Y" THEN EXIT SUB ' Convert A$ to UpperCase CLS CALL Status CALL RestoreCursor END SUB ' ClearScreen ' PageDn toggles special arrow keys on/off SUB PageDn SHARED Arrow,OldArrow IF Arrow =0 THEN ' Test current setting Arrow =OldArrow ' Restore old setting CALL Status ' Update status line CALL RestoreCursor EXIT SUB ' EXIT END IF Arrow =0 ' Turn off arrow keys CALL Status END SUB ' PageDn ' ************** Cursor positioning routines *************** SUB EndofLine SHARED Xpos LOCATE CSRLIN,80 Xpos=80 END SUB ' EndofLine SUB BeginofLine SHARED Xpos LOCATE CSRLIN,1 Xpos=1 END SUB ' BeginofLine SUB MidScreen SHARED Xpos LOCATE CSRLIN,40 Xpos =40 END SUB ' MidScreen SUB CtrlHome SHARED Xpos,Ypos Xpos=1 : Ypos=1 LOCATE Ypos,Xpos END SUB ' CtrlHome SUB CtrlEnd SHARED Xpos,Ypos Xpos=80 : Ypos=24 LOCATE Ypos,Xpos END SUB ' CtrlEnd SUB BackSpace Xpos = POS : Ypos = CSRLIN ' Get Current position IF Xpos=1 THEN EXIT SUB ' Column 1 ? Xpos=Xpos-1 ' Back-up one space LOCATE Ypos,Xpos ? " "; ' Clear character LOCATE Ypos,Xpos ' Restore cursor position END SUB ' ************** Arrow Routines *************** SUB MoveRight SHARED Xpos,Ypos,Arrow,LastChar$ IF Arrow=1 THEN A$="─" ' Single Border ? IF Arrow=2 THEN A$="═" ' Double Border ? IF Arrow=3 THEN A$=LastChar$ ' Print Last Character ? IF Arrow=4 THEN A$=CHR$(SCREEN(Ypos,Xpos)) ' Change Color ? IF Arrow > 0 THEN ' Special arrow keys on ? CALL InsertText(A$) ' OutPut Character END IF Xpos=Xpos+1 IF Xpos>79 THEN Xpos=80 LOCATE Ypos,Xpos END SUB ' MoveRight SUB MoveLeft SHARED Xpos,Ypos,Arrow,LastChar$ IF Arrow=1 THEN A$="─" ' Single Border IF Arrow=2 THEN A$="═" ' Double Border IF Arrow=3 THEN A$=LastChar$ ' Print Last Character IF Arrow=4 THEN A$=CHR$(SCREEN(Ypos,Xpos)) ' Change Color ? IF Arrow > 0 THEN ' Special arrow keys on ? CALL InsertText(A$) ' OutPut Character END IF Xpos=Xpos-1:IF Xpos<1 THEN Xpos=1 LOCATE Ypos,Xpos END SUB ' MoveLeft SUB MoveUp SHARED Xpos,Ypos,Arrow,LastChar$ IF Arrow=1 THEN A$="│" ' Single Border IF Arrow=2 THEN A$="║" ' Double Border IF Arrow=3 THEN A$=LastChar$ ' Last Character IF Arrow=4 THEN A$=CHR$(SCREEN(Ypos,Xpos)) ' Change Color ? IF Arrow > 0 THEN ' Special arrow keys on ? CALL InsertText(A$) ' Output Character END IF Ypos=Ypos-1:IF Ypos<1 THEN Ypos=1 LOCATE Ypos,Xpos END SUB ' MoveUp SUB MoveDown SHARED Xpos,Ypos,Arrow,LastChar$ IF Arrow =1 THEN A$="│" ' Single Border IF Arrow =2 THEN A$="║" ' Double Border IF Arrow =3 THEN A$=LastChar$ ' Last Character IF Arrow=4 THEN A$=CHR$(SCREEN(Ypos,Xpos)) ' Change Color ? IF Arrow > 0 THEN ' Special arrow keys on ? CALL InsertText(A$) ' Output Character END IF Ypos=Ypos+1:IF Ypos>23 THEN Ypos=24 LOCATE Ypos,Xpos END SUB ' MoveDown ' F2 - FILES key SUB F2 Xpos=POS : Ypos=CSRLIN ' Get current position CALL FileService SCREEN 0,0,0,0 ' Back to Program CALL RestoreCursor CALL Status END SUB ' F2 ' F5 - COLORS key SUB F5 SHARED CurrentFore,CurrentBack Xpos=POS : Ypos=CSRLIN ' Get Current Position ' CALL Colors Routine CALL Colors(CurrentFore,CurrentBack) CALL RestoreCursor END SUB ' F5 ' F6 - SPECIAL character key SUB F6 SHARED YSpec,XSpec,WLarge(),WSCharData(),A$ LOCATE 1,1,0 ' Hide Cursor & Open Window CALL OPENWINDOW(WLarge(),WSCharData()) COLOR 14,0 LOCATE 2,2 ?" " : LOCATE 3,2 ?" " : LOCATE 4,2 ?" ";CHR$(26);" Ç ü é " : LOCATE 5,2 ?" " : LOCATE 6,2 ?" â ä à å ç ê ë è ï î ì Ä " : LOCATE 7,2 ?" " : LOCATE 8,2 ?" Å É æ Æ ô ö ò û ù ÿ Ö Ü " : LOCATE 9,2 ?" " : LOCATE 10,2 ?" ¢ £ ¥ ₧ ƒ á í ó ú ñ Ñ ª " : LOCATE 11,2 ?" " : LOCATE 12,2 ?" º ¿ ⌐ ¬ ½ ¼ ¡ « » ░ ▒ ▓ " : LOCATE 13,2 ?" " : LOCATE 14,2 ?" █ ▄ ▌ ▐ ▀ α ß Γ π Σ σ µ " : LOCATE 15,2 ?" " : LOCATE 16,2 ?" τ Φ Θ Ω δ ∞ φ ε ∩ ≡ ± ≥ " : LOCATE 17,2 ?" " : LOCATE 18,2 ?" ≤ ⌠ ⌡ ÷ ≈ ° ∙ · √ ⁿ ² ■ " : LOCATE 19,2 ?" " : LOCATE 20,2 : COLOR 11,0 ?" Escape to EXIT! " CALL CharSelect(A$,YSpec,XSpec,2,2,35,18) ' HighLight Character CALL CLOSEWINDOW(WLarge(),WSCharData()) ' Close Window & CALL RestoreCursor ' Restore Cursor IF A$ <> CHR$(0) THEN CALL InsertText(A$) ' Print Character END SUB ' F6 ' F7 - BOX character key SUB F7 SHARED YBox,XBox,WLarge(),WBCharData(),A$ LOCATE 1,1,0 ' Hide Cursor & CALL OPENWINDOW(WLarge(),WBCharData()) ' Open Window COLOR 14,0 LOCATE 2,2 ?" ╒ ╤ ╕ ╓ ╥ ╖ " : LOCATE 3,2 ?" " : LOCATE 4,2 ?" ╞ ╪ ╡ ╟ ╫ ╢ " : LOCATE 5,2 ?" " : LOCATE 6,2 ?" ╘ ╧ ╛ ╙ ╨ ╜ " : LOCATE 7,2 ?" " : LOCATE 8,2 ?" ╔ ╦ ╗ ┌ ┬ ┐ " : LOCATE 9,2 ?" " : LOCATE 10,2 ?" ╠ ╬ ╣ ├ ┼ ┤ " : LOCATE 11,2 ?" " : LOCATE 12,2 ?" ╚ ╩ ╝ └ ┴ ┘ " : LOCATE 13,2 COLOR 11,0:?" Escape to exit! " CALL CharSelect(A$,YBox,XBox,2,2,17,12) ' HighLight Character CALL CLOSEWINDOW(WLarge(),WBCharData()) ' Close Window CALL RestoreCursor ' Restore Cursor IF A$ <> CHR$(0) THEN CALL InsertText(A$) ' Print Character END SUB ' F7 ' F8 - Rotate Options -Last character/Single Border/Double Border/Change Color ' Arrow will equal 0 - Special Arrow keys off ' 1 - Single Border ' 2 - Double Border ' 3 - Last Character ' 4 - Change Color under cursor SUB F8 SHARED Arrow,OldArrow,Border$() IF Arrow = 0 THEN EXIT SUB ' Are special arrow keys on ? Arrow = Arrow + 1 ' Rotate status by 1 IF Arrow > 4 THEN Arrow = 1 OldArrow = Arrow Xpos=POS : Ypos=CSRLIN ' Get Current Position COLOR 11,0 ' Set Status line color LOCATE 25,1 ' Position cursor LOCATE 25,22,0 : ? "=";Border$(Arrow); CALL RestoreCursor ' Restore cursor END SUB ' F8 ' F9 - SUB F9 SHARED CurrentFore,CurrentBack,Path$,FileName$,InitialPath$ SHARED Mask$,StatColor$ LOCAL StatBack$,StatFore$,Fore Xpos=POS : Ypos=CSRLIN ' Get current position SCREEN 0,0,2,0 ' Screen 2 for HELP COLOR 7,0 CLS StatBack$=MID$(StatColor$,(CurrentBack*7)+1,7) Fore=CurrentFore IF Fore > 23 THEN StatFore$="Blinking High Intensity " Fore=Fore-24 END IF IF Fore > 15 THEN StatFore$="Blinking " Fore=Fore-16 END IF IF Fore > 7 THEN StatFore$="High Intensity " Fore=Fore-8 END IF StatFore$=StatFore$+MID$(StatColor$,(Fore*7)+1,7) ?" Current Setting " ? ?" Background Color: ";StatBack$ ?" Foreground Color: ";StatFore$ ? ?" File Name: ";FileName$ ?" Directory: ";Path$ ?" Mask Setting: ";Mask$ ? ?" Help Directory: ";InitialPath$ ? : ? ?" Press any key to continue ..."; SCREEN 0,0,0,2 CALL GetKey(A$) SCREEN 0,0,0,0 ' Back to Program CALL RestoreCursor END SUB ' F9 ' F10 - Show command menu SUB F10 SCREEN 0,0,0,1 ' SCREEN 1 for Commands Menu WHILE NOT INSTAT : WEND ' Wait for keypress SCREEN 0,0,0,0 ' Return END SUB ' F10 ' ************* SUBROUTINES ***************** ' Status updates entire status line SUB Status SHARED Xpos,Ypos,Arrow,Border$(),Arrow$ Ypos=CSRLIN : Xpos=POS ' Get Current Position LOCATE 25,1 COLOR 14,0 ? "Line Col ";Arrow$;" Esc F1 or F10 "; COLOR 11,0 LOCATE 25,5,0 : ? "=";Ypos; ' Print status information LOCATE 25,13,0 : ? "=";Xpos; LOCATE 25,22,0 : ? "=";Border$(Arrow); LOCATE 25,52,0 : ? "-Exit"; LOCATE 25,71,0 : ? "-Help"; CALL LowerCorner(32,0,3998) ' Poke Character into Lower Corner CALL RestoreCursor ' Restore Position END SUB ' Status ' LowerCorner Pokes the character and attribute into video ' Otherwise printing character will scroll top line off the screen SUB LowerCorner(Character,Attr,Position) SHARED VideoOffset DEF SEG=%VideoSegment ' Point to Video Segment POKE Position,Character ' Poke Character & POKE Position+1,Attr ' Attribute DEF SEG ' Return Segment END SUB ' LowerCorner ' InsertText(A$) Inserts Text (A$) at the current cursor location SUB InsertText(A$) SHARED LastChar$,CurrentFore,CurrentBack IF ASC(A$) > 6 AND ASC(A$) < 14 THEN EXIT SUB ' Non-printing IF ASC(A$) > 28 AND ASC(A$) < 32 THEN EXIT SUB ' Characters Xpos=POS:Ypos=CSRLIN ' Current Position IF Xpos > 79 AND Ypos=24 THEN ' Is this the Lower Corner? A=ASC(A$) ' Get Character B=CurrentBack*16+CurrentFore ' and Color Position=3838 ' and Position CALL LowerCorner(A,B,Position) ' Poke it in EXIT SUB ' EXIT END IF LOCATE Ypos,Xpos ' Normal Printing ? A$; LastChar$=A$ ' Store Character for Repeat END SUB ' InsertText 'CharSelect Highlights 3 characters. Used to select from characters window. 'A$=Character under cursor when RETURN is pressed. 'Y,X=Position to start highlighting 'XMin,YMin,XMax,YMax=Minimum and Maximum X,Y positions within the window SUB CharSelect(A$,Y,X,XMin,YMin,XMax,YMax) SHARED TextHigh,TextNorm DO CALL HighLightText(Y,X,3,TextHigh) ' HighLight Text CALL Getkey(A$) ' Wait for keypress IF A$=CHR$(27) THEN A$=CHR$(0) : EXIT SUB ' ESCAPE ? IF LEFT$(A$,1)=CHR$(0) THEN ' Extended Key Code ? CALL Extkey(A$,K) ' Get Code IF K=77 THEN ' MOVE RIGHT CALL HighLightText(Y,X,3,TextNorm) X=X+3 : IF X > XMax THEN X=XMax END IF IF K=75 THEN ' MOVE LEFT CALL HighLightText(Y,X,3,TextNorm) X=X-3 : IF X < XMin THEN X=XMin END IF IF K=72 THEN ' MOVE UP CALL HighLightText(Y,X,3,TextNorm) Y=Y-2 : IF Y < YMin THEN Y=YMin END IF IF K=80 THEN ' MOVE DOWN CALL HighLightText(Y,X,3,TextNorm) Y=Y+2 : IF Y > YMax THEN Y=YMax END IF END IF LOOP UNTIL A$=CHR$(13) ' Wait for RETURN A=SCREEN (Y,X+1) ' Read Character from Screen A$=CHR$(A) ' and Print it END SUB ' CharSelect ' HighLightText(Y,X,WL,Attr) Highlights text ' Y=ROW X=COL WL=Word Length Attr=Color SUB HighLightText(Y,X,WL,Attr) SHARED VideoOffset LOCAL T,Row,Col,WordLength Row=Y Col=X WordLength=WL Row=Row-1 Col=(Col-1)*2 WordLength=WordLength*2+Col DEF SEG=%VideoSegment + (Row*10) ' Define Screen Segment WHILE Col < WordLength POKE Col+1,Attr ' Poke Attribute INCR Col,2 ' to HighLight Text WEND DEF SEG ' Return to Segment END SUB ' HighLightText ' EXIT routine GOODBYE: SCREEN 0,0,0,0 CALL OPENWINDOW(WSmall(),WErrData()) ' Open Exit Window LOCATE 12,29,0 COLOR 15,4 ?"Exit? Are you sure?(Y/N)"; ' Sure ? WHILE NOT INSTAT:WEND ' Wait for keypress A$=INKEY$ CALL CLOSEWINDOW(WSmall(),WErrData()) ' Close Window CALL RestoreCursor ' Restore Position IF UCASE$(A$) = "Y" THEN GOTO SureDone ' Convert A$ to UpperCase GOTO START ' Return if NOT Y SureDone: ' Yes, EXIT END ' ******************* BLOCK ROUTINES ******************** SUB Block SHARED CurrentFore,CurrentBack,Xpos,Ypos,Arrow LOCAL XBegin,YBegin,XEnd,YEnd,ArrowStat ArrowStat =0 IF Arrow <> 0 THEN CALL PageDn ' Turn off special arrow keys ArrowStat = 1 ' Set Flag END IF XBegin=Xpos : YBegin=Ypos ' Current Position when COLOR 14,0 ' when Routine is Called LOCATE 25,1 ?" Move cursor to location and F4 to mark block end. Esc-Exit "; LOCATE Ypos,Xpos DO DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) THEN A$=CHR$(0)+CHR$(0) ' ESCAPE ? LOOP UNTIL LEFT$(A$,1)=CHR$(0) ' Wait For Extened Key CALL Extkey(A$,K) ' Get Code IF K=0 THEN EXIT LOOP ' Escape, So EXIT IF K=71 THEN CALL BeginofLine ' HOME IF K=79 THEN CALL EndofLine ' END IF K=77 THEN CALL MoveRight ' RIGHT ARROW IF K=75 THEN CALL MoveLeft ' LEFT ARROW IF K=72 THEN CALL MoveUp ' UP ARROW IF K=80 THEN CALL MoveDown ' DOWN ARROW IF K=115 THEN CALL MidScreen ' Middle Screen IF K=116 THEN CALL MidScreen ' Middle Screen IF K=119 THEN CALL CtrlHome ' UpperLeft Corner IF K=117 THEN CALL CtrlEnd ' LowerRight Corner LOOP UNTIL K=62 ' Wait for F4 key IF K=0 THEN IF ArrowStat =1 THEN CALL PageDn ' Turn on special arrow keys CALL Status EXIT SUB ' Escape EXIT END IF XEnd=Xpos : YEnd=Ypos ' Get Position IF XEnd < XBegin THEN SWAP XEnd,XBegin ' Put Smaller Position in Begin IF YEnd < YBegin THEN SWAP YEnd,YBegin ' Put Larger Position in End COLOR 14,0 LOCATE 25,1 ?" F1-Character Fill F3-Single Border F5-Double Border F7-Copy Esc-Exit "; LOCATE Ypos,Xpos DO DO CALL Getkey(A$) ' Get KeyPress IF A$=CHR$(27) THEN A$=CHR$(0)+CHR$(0) ' ESCAPE ? LOOP UNTIL LEFT$(A$,1)=CHR$(0) ' Wait for Extended Key CALL Extkey(A$,K) ' Get Code IF K=0 THEN EXIT LOOP ' Escape, so EXIT IF K=59 THEN CALL CharFill(XBegin,YBegin,XEnd,YEnd) : EXIT LOOP IF K=61 THEN CALL SingleFill(XBegin,YBegin,XEnd,YEnd) : EXIT LOOP IF K=63 THEN CALL DoubleFill(XBegin,YBegin,XEnd,YEnd) : EXIT LOOP IF K=65 THEN CALL CopyBlock(XBegin,YBegin,XEnd,YEnd) : EXIT LOOP LOOP LOCATE Ypos,Xpos IF ArrowStat =1 THEN CALL PageDn ' Turn on special arrow keys CALL Status END SUB ' Block ' Character fill routine SUB CharFill(XBegin,YBegin,XEnd,YEnd) LOCAL X,Y,FillLength,FillWord$ SHARED CurrentFore,CurrentBack,A$ COLOR 14,0 LOCATE 25,1 ?" Input character to FILL ";:COLOR 11,0 : ?" F6"; : COLOR 14,0 ?"-Special "; : COLOR 11,0 : ?" F7"; : COLOR 14,0 : ?"-Box Characters "; COLOR 11,0 : ?" Esc"; : COLOR 14,0 : ?"-Exit "; DO LOCATE 25,26 CALL Getkey(A$) ' Get KeyPress IF A$=CHR$(27) THEN A$=CHR$(7) ' ESCAPE ? IF LEFT$(A$,1)=CHR$(0) THEN ' Extended Key ? CALL Extkey(A$,K) ' Get Code IF K=64 THEN CALL F6 ' Special Character IF K=65 THEN CALL F7 ' Box Character END IF LOOP UNTIL LEFT$(A$,1) <> CHR$(0) COLOR CurrentFore,CurrentBack ' Non-printing Characters IF ASC(A$) > 6 AND ASC(A$) < 14 THEN LOCATE YEnd,XEnd : EXIT SUB IF ASC(A$) > 28 AND ASC(A$) < 32 THEN LOCATE YEnd,XEnd : EXIT SUB FillLength=(XEnd+1)-XBegin FillWord$=STRING$(FillLength,ASC(A$)) ' Set FillWord$ Y=YBegin WHILE Y <= YEnd X=XBegin IF X + FillLength > 79 AND Y=24 THEN ' Check For Lower Corner A=ASC(A$) ' Character B=CurrentBack*16+CurrentFore ' Color Position=3838 ' Position CALL LowerCorner(A,B,Position) ' Poke into Screen LOCATE 24,X ? LEFT$(FillWord$,FillLength-1); LOCATE YEnd,XEnd EXIT SUB END IF LOCATE Y,X ' Position Cursor ? FillWord$; ' Print String Y=Y+1 ' Increment Y(NEXT LINE) WEND ' Loop LOCATE YEnd,XEnd END SUB ' CharFill ' Single border box routine SUB SingleFill(XBegin,YBegin,XEnd,YEnd) SHARED CurrentFore,CurrentBack LOCAL LastLine$,LastLength IF XEnd-XBegin < 1 THEN LOCATE 1,1 : EXIT SUB IF YEnd-YBegin < 1 THEN LOCATE 1,1 : EXIT SUB LOCATE YBegin,XBegin ' Position Cursor COLOR CurrentFore,CurrentBack ' Set Color ?"┌";STRING$((XEnd-XBegin)-1,196);"┐"; ' Set-up String to print YBegin=YBegin+1 ' Increment Line WHILE YBegin < YEnd LOCATE YBegin,XBegin : ?"│"; ' Print first edge of Border LOCATE YBegin,XEnd : ?"│"; ' Second Edge YBegin=YBegin+1 ' Increment Line WEND LastLine$="└"+STRING$((XEnd-XBegin)-1,196)+"┘" ' Last Line LastLength=LEN(LastLine$) IF XBegin + LastLength > 79 AND YBegin=24 THEN ' Check for Lwer Corner A=217 ' Character to Print B=CurrentBack*16+CurrentFore ' Color Position=3838 ' Position CALL LowerCorner(A,B,Position) ' Poke Character LOCATE 24,XBegin ? LEFT$(LastLine$,LastLength-1); LOCATE YEnd,XEnd EXIT SUB END IF LOCATE YBegin,XBegin ? LastLine$; LOCATE YEnd,XEnd END SUB ' SingleFill ' Double border box routine SUB DoubleFill(XBegin,YBegin,XEnd,YEnd) SHARED CurrentFore,CurrentBack LOCAL LastLine$,LastLength IF XEnd-XBegin < 1 THEN LOCATE 1,1 : EXIT SUB IF YEnd-YBegin < 1 THEN LOCATE 1,1 : EXIT SUB LOCATE YBegin,XBegin ' Set Cursor COLOR CurrentFore,CurrentBack ?"╔";STRING$((XEnd-XBegin)-1,205);"╗"; ' Print First Line YBegin=YBegin+1 ' Increment Line WHILE YBegin < YEnd LOCATE YBegin,XBegin : ?"║"; ' Print First edge LOCATE YBegin,XEnd : ?"║"; ' Print Second edge YBegin=YBegin+1 ' Increment Line WEND ' Loop LastLine$="╚"+STRING$((XEnd-XBegin)-1,205)+"╝" ' Set-up Last Line LastLength=LEN(LastLine$) IF XBegin + LastLength > 79 AND YBegin=24 THEN ' Check for Lower Corner A=188 ' Character to Print B=CurrentBack*16+CurrentFore ' Color Position=3838 ' Position CALL LowerCorner(A,B,Position) ' Poke Character LOCATE 24,XBegin ? LEFT$(LastLine$,LastLength-1); LOCATE YEnd,XEnd EXIT SUB END IF LOCATE YBegin,XBegin ' If NOT Lower Corner ? LastLine$; ' then Print Line LOCATE YEnd,XEnd END SUB ' DoubleFill ' Copy block routine SUB CopyBlock(XBegin,YBegin,XEnd,YEnd) SHARED CurrentFore,CurrentBack,WLarge(),WBlockData(),WLarge2() LOCAL T ' Set-up Window Data WBlockData(0)=YBegin-1 ' ROW WBlockData(1)=XBegin-1 ' COL WBlockData(2)=(XEnd-XBegin)+1 ' WIDTH WBlockData(3)=(YEnd-YBegin)+1 ' LENGTH WBlockData(4)=(CurrentBack*16)+CurrentFore ' COLOR WBlockData(5)=0 ' BORDER TYPE (0=no border) CALL OPENWINDOW(WLarge(),WBlockData()) ' Block Data Window CALL OPENWINDOW(WLarge2(),WBlockData()) ' Area under block COLOR 14,0 LOCATE 25,1 ?" Move cursor to new location and press Return to COPY block. Esc-Exit "; DO CALL Getkey(A$) ' Get Keypress IF LEFT$(A$,1)=CHR$(0) THEN ' Test for Extended Key CALL Extkey(A$,K) ' Get Code CALL CLOSEWINDOW(WLarge2(),WBlockData()) ' Area under window IF K=71 THEN WBlockdata(1)=0 ' HOME IF K=79 THEN WBlockData(1)=80-WBlockdata(2) ' END IF K=77 THEN ' RIGHT WBlockData(1)=WBlockData(1)+1 IF WBLockData(1)+WBlockData(2) > 80 THEN WBlockData(1)=80-WBlockData(2) END IF END IF IF K=75 THEN ' LEFT WBlockData(1)=WBlockData(1)-1 IF WBlockData(1) < 0 THEN WBlockData(1)=0 END IF IF K=72 THEN ' UP WBlockData(0)=WBlockData(0)-1 IF WBlockData(0) < 0 THEN WBlockData(0)=0 END IF IF K=80 THEN ' DOWN WBlockData(0)=WBlockData(0)+1 IF WBlockData(0)+WBlockData(3) > 24 THEN WBlockdata(0)=24-WBlockData(3) END IF END IF IF K=119 THEN ' UPPER CORNER WBlockData(0)=0 WBlockdata(1)=0 END IF IF K=117 THEN ' LOWER CORNER WBlockData(1)=80-WBlockdata(2) WBlockData(0)=24-WBlockData(3) END IF CALL OPENWINDOW(WLarge2(),WBlockData()) ' Area under block CALL CLOSEWINDOW(WLarge(),WBlockData()) ' Block Data END IF IF A$=CHR$(27) THEN EXIT LOOP ' ESCAPE ? IF A$=CHR$(13) THEN ' Return ? CALL OPENWINDOW(WLarge2(),WBlockData()) ' New data under window CALL CLOSEWINDOW(WLarge(),WBlockData()) ' Block Data END IF LOOP CALL CLOSEWINDOW(WLarge2(),WBlockData()) ' Replace area under block ERASE WLarge,WLarge2,WBlockData ' Clear Arrays END SUB ' CopyBlock ' ********************* FILES routines ********************* SUB FileService SHARED WLarge(),WFilesData(),FY,TextHigh,TextNorm,Path$,FileName$ LOCATE 2,6,0 : COLOR 14,0 CALL OPENWINDOW(WLarge(),WFilesData()) ' Open Files Window COLOR 14,0 LOCATE 2,6,0 : COLOR 14,0 ?" FILES " LOCATE 3,3 ?" " : LOCATE 4,3 ?" File Name " : LOCATE 5,3 ?" Save File " : LOCATE 6,3 ?" Load File " : LOCATE 7,3 ?" Change Dir " : LOCATE 8,3 ?" Directory " : LOCATE 9,3 ?" DOS Shell " CALL HighLightText(FY,3,13,TextHigh) ' HighLight Text DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) THEN ' ESCAPE ? CALL CLOSEWINDOW(WLarge(),WFilesData()) ' Close Window EXIT SUB ' and Exit END IF IF LEFT$(A$,1)=CHR$(0) THEN ' Extended Key ? CALL Extkey(A$,K) ' Get Code IF K=72 THEN ' MOVE UP CALL HighLightText(FY,3,13,TextNorm) IF FY = 4 THEN FY = 10 ' Check Location FY=FY-1 CALL HighLightText(FY,3,13,TextHigh) END IF IF K=80 THEN ' MOVE DOWN CALL HighLightText(FY,3,13,TextNorm) IF FY = 9 THEN FY = 3 ' Check Location FY=FY+1 CALL HighLightText(FY,3,13,TextHigh) END IF END IF IF A$=CHR$(13) THEN ' RETURN ? IF FY = 4 THEN CALL ChangeFileName ' Change File ? IF FY = 5 THEN ' Save File ? CALL SaveFile(Stat) IF Stat=1 THEN EXIT LOOP ' No Errors ? END IF IF FY = 6 THEN ' Load File ? CALL CLOSEWINDOW(WLarge(),WFilesData()) ' Close Window CALL LoadFile EXIT LOOP ' EXIT END IF IF FY = 7 THEN CALL ChangePath ' Change Path ? IF FY = 8 THEN CALL Directory ' Directory ? IF FY = 9 THEN GOTO DOSSHELL ' SHELL ? END IF LOOP ' Loop until ESCAPE END SUB ' FileService ' ********************** FILENAME ********************* SUB ChangeFileName SHARED FileName$,GoodFileName$,WSmall(),WFileNameData() LOCAL NewFileName$ CALL OPENWINDOW(WSmall(),WFileNameData()) ' Open FileName Window LOCATE 3,20 : COLOR 14,0 ?" FileName " LOCATE 4,19,1,1,7 ? FileName$; ' Print Current FileName LOCATE 4,19 DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) OR A$=CHR$(13) THEN ' Escape OR Return ? CALL CLOSEWINDOW(WSmall(),WFileNameData()) ' Close Window LOCATE 1,1,0 EXIT SUB ' and EXIT END IF ' If not EXIT then LOOP UNTIL INSTR(GoodFileName$,A$) <> 0 ' Wait for Legal Character NewFileName$=A$ ' Set Variable DO LOCATE 4,19 : ? SPACE$(8) ' Clear Line LOCATE 4,19 : ? NewFileName$; ' Print New Filename CALL Getkey(A$) ' Get Next Character IF A$=CHR$(27) THEN ' Escape ? LOCATE 1,1,0 CALL CLOSEWINDOW(WSmall(),WFileNameData()) ' Close Window EXIT SUB END IF ' Check For Legal Characters IF INSTR(GoodFileName$,A$) <> 0 THEN NewFileName$=NewFilename$+A$ ' BACKSPACE IF A$=CHR$(8) THEN IF LEN(NewFileName$) > 0 THEN NewFileName$=LEFT$(NewFileName$,(LEN(NewFileName$)-1)) END IF IF LEN(NewFileName$) > 7 THEN ' More then 8 characters ? NewFileName$=LEFT$(NewFileName$,8) END IF LOOP UNTIL A$=CHR$(13) ' Wait For Return FileName$=NewFileName$ ' Save New Name CALL CLOSEWINDOW(WSmall(),WFileNameData()) ' Close Window LOCATE 1,1,0 END SUB ' ChangeFileName ' ************************ LOAD FILE ************************** SUB LoadFile SHARED FileName$,VideoOffset,Path$ LOCAL File$,FileSize,KeyStroke$ File$=Path$ IF RIGHT$(File$,1) <> "\" THEN File$=File$+"\" File$=File$+FileName$+".SCR" ' Set Filename with Extension CALL FileCheck(File$,FileSize) ' Check File IF FileSize = 0 THEN ' File Length = 0 ? CALL DiskError(2) ' Print Error EXIT SUB ' and EXIT END IF IF FileSize <> 3848 THEN ' ALL Screen files are 3848 bytes CALL DiskError(3) ' Print Error EXIT SUB ' and EXIT END IF DEF SEG = %VideoSegment ' Set Segment to Video BLOAD File$,0 ' Load File DEF SEG ' Return Segment END SUB ' LoadFile ' *********************** SAVE FILE ********************** SUB SaveFile(Stat) SHARED FileName$,WSmall(),WSaveData(),XSave,YSave,TextHigh,TextNorm SHARED WLarge(),WFilesData(),VideoOffset,Path$ LOCAL File$,FileSize,Free!,KeyStroke$,SaveType Stat=0 ' Initialize Stat CALL OPENWINDOW(WSmall(),WSaveData()) ' Open Window LOCATE 4,24 : COLOR 14,0 ?" Format " LOCATE 5,18,0 ? " SCR ANS BAS All " DO ' Get File Type CALL HighLightText(YSave,XSave,5,TextHigh) CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) THEN ' ESCAPE ? CALL CLOSEWINDOW(WSmall(),WSaveData())' Close Window EXIT SUB ' and EXIT END IF IF LEFT$(A$,1)=CHR$(0) THEN ' Extended Key ? CALL Extkey(A$,K) ' Get Code IF K=77 THEN ' MOVE RIGHT CALL HighLightText(YSave,XSave,5,TextNorm) XSave=XSave+5 : IF XSave > 33 THEN XSave=18 END IF IF K=75 THEN ' MOVE LEFT CALL HighLightText(YSave,XSave,5,TextNorm) XSave=XSave-5 : IF XSave < 18 THEN XSave=33 END IF END IF LOOP UNTIL A$=CHR$(13) ' Loop until Return CALL CLOSEWINDOW(WSmall(),WSaveData()) ' Close Windows CALL CLOSEWINDOW(WLarge(),WFilesData()) Stat=1 ' O.K. SaveType=(XSave-18)/5 ' Get Type File$=Path$ IF RIGHT$(File$,1) <> "\" THEN File$=File$+"\" File$=File$+FileName$+".SCR" ' Save Screen format first CALL FileCheck(File$,FileSize) ' Check File IF FileSize <> 0 THEN ' Does File Exist ? LOCATE 25,1 : COLOR 14,0 ? SPACE$(79); : LOCATE 25,1 ' Print Message ? " File ";FileName$;".SCR Exists. Do you want to OverWrite.(Y/N) "; CALL Getkey(A$) ' Get KeyPress IF UCASE$(A$)="N" THEN EXIT SUB ' OverWrite ? END IF ' Check available space on drive REG 4,0 REG 1,&h3600 CALL INTERRUPT &H21 Free!=CSNG(REG(2)) * REG(3) * REG(1) IF Free! < 4000 THEN CALL DiskError(1) ' Not enough room on drive EXIT SUB END IF LOCATE 25,1 COLOR 14,0 ? " Saving File. Please wait! "; DEF SEG = %VideoSegment ' Video Segment BSAVE File$,0,3840 ' Save File DEF SEG ' Return to Segment IF SaveType=1 THEN CALL AnsiSave(FileName$) ' ANSI format Save IF SaveType=2 THEN CALL BasicSave(FileName$) ' BASIC format Save IF SaveType=3 THEN ' ANSI & BASIC Save CALL AnsiSave(FileName$) CALL BasicSave(FileName$) END IF END SUB ' SaveFile ' ************************ ANSI SAVE ************************ SUB AnsiSave(FileName$) 'AnsiSave Saves Screen Colors and text in ANSI Format. ' CALL AnsiSave(FileName$) with Filename$=File Name SHARED VideoOffset,Path$ LOCAL LinePointer,ChrPointer,Attr,Lin$,Esc$ Esc$=CHR$(27)+"[" ' Escape Sequence File$=Path$ IF RIGHT$(File$,1) <> "\" THEN File$=File$+"\" File$=FileName$+".ANS" ' Set Filename and Extension CALL FileCheck(File$,FileSize) ' Check File IF FileSize <> 0 THEN ' File Exists LOCATE 25,1 : COLOR 14,0 ? SPACE$(79); : LOCATE 25,1 : COLOR 14,0 ' Print Message to User ? " File ";FileName$;".ANS Exists. Do you want to OverWrite.(Y/N) "; CALL Getkey(A$) ' Get Keypress IF UCASE$(A$)="N" THEN EXIT SUB ' OverWrite ? END IF LOCATE 25,1 COLOR 14,0 ? " Saving File. Please wait! "; ON ERROR GOTO AnsiSaveError ' Error Checking Enabled OPEN File$ FOR OUTPUT AS #1 ' Open File Lin$=Esc$+"2J"+Esc$+"=7l" ' Clear Screen and ' Turn off Word Wrap PRINT #1,Lin$ ' OutPut Line Attr=256 ' Initialize Attribute FOR LinePointer=0 TO 23 ' Save 24 lines Lin$="" ' Clear Lin$ ' Def Seg for start of each line DEF SEG=%VideoSegment+(LinePointer*10) ChrPointer=0 ' Initialize Character Pointer DO ' Did color change ? IF Attr <> PEEK(ChrPointer+1) THEN CALL NewColor(ChrPointer,Attr,Lin$) Lin$=Lin$+CHR$(PEEK(ChrPointer)) ' TextString To Be Output ChrPointer=ChrPointer+2 ' Increment Pointer LOOP UNTIL ChrPointer > 158 ' End of Line PRINT #1,Lin$ ' Output TextString NEXT LinePointer ' Next Line Lin$="" ' Clear Lin$ Lin$=Esc$+"=7h"+Esc$+"3A" ' Turn On Word Wrap ' & Move Up 3 Rows PRINT #1,Lin$ ' Output Line Lin$=Esc$+"0m" ' Reset Screen Color PRINT #1,Lin$ CLOSE #1 ' Close and Exit ON ERROR GOTO 0 ' Disable Error Checking EXIT SUB ' EXIT ' Saving Errors Come here AnsiSaveError: CLOSE #1 ' Close File RESUME AnsiError AnsiError: ON ERROR GOTO 0 ' Disable Error Checking CALL DiskError(1) ' Print Error Message END SUB ' AnsiSave ' NEW COLOR FOR ANSI FILES SUB NewColor(ChrPointer,Attr,Lin$) LOCAL AnsiCom$,AnsiFore$,AnsiBack$,Blink,High,Esc$,TempAttr,Back,Fore Esc$=CHR$(27)+"[" ' Escape Sequence AnsiCom$="" Blink=0 : High=0 Attr=PEEK(ChrPointer+1) ' Get Attribute TempAttr=Attr ' Into TempAttr IF TempAttr > 127 THEN ' Test for Blinking Char TempAttr=TempAttr-128 Blink=1 END IF Back=TempAttr\16 ' Background Fore=TempAttr-(Back*16) IF Fore > 7 THEN ' Test for HIGH Intensity Fore=Fore-8 High=1 END IF CALL AnsiColor(Back) CALL AnsiColor(Fore) AnsiBack$=MID$(STR$(40+Back),2,2)+"m" ' ANSI Background Color AnsiFore$=MID$(STR$(30+Fore),2,2)+";" ' ANSI Foreground Color AnsiCom$=Esc$ IF Blink=1 THEN ' Blinking Character ? AnsiCom$=AnsiCom$+"5;" END IF IF High=1 THEN ' High Intensity ? AnsiCom$=AnsiCom$+"1;" END IF Lin$=Lin$+Esc$+"m" Lin$=Lin$+AnsiCom$+AnsiFore$+AnsiBack$ ' Set-up Output String END SUB ' NewColor (ANSI files) ' ANSI Color Codes SUB AnsiColor(Code) IF Code=1 THEN Code=4 : EXIT SUB ' Blue IF Code=3 THEN Code=6 : EXIT SUB ' Cyan IF Code=4 THEN Code=1 : EXIT SUB ' Red IF Code=6 THEN Code=3 : EXIT SUB ' Yellow IF Code=0 THEN Code=0 : EXIT SUB ' Black IF Code=2 THEN Code=2 : EXIT SUB ' Green IF Code=5 THEN Code=5 : EXIT SUB ' Magenta IF Code=7 THEN Code=7 ' White END SUB ' AnsiColor ' ************************ BASIC SAVE ************************ 'BasicSave Saves Screen Colors and text in BASIC file Format. ' CALL BasicSave(FileName$) with Filename$=File Name SUB BasicSave(FileName$) SHARED VideoOffset,Path$ LOCAL LinePointer,ChrPointer,Attr,Lin$,LineNumber,TempText$ File$=Path$ IF RIGHT$(File$,1) <> "\" THEN File$=File$+"\" File$=FileName$+".BAS" ' Set Filename and Extension CALL FileCheck(File$,FileSize) ' Check File IF FileSize <> 0 THEN ' Does File Exist LOCATE 25,1 : COLOR 14,0 ? SPACE$(79); : LOCATE 25,1 : COLOR 14,0 ' Print Message ? " File ";FileName$;".BAS Exists. Do you want to OverWrite.(Y/N) "; CALL Getkey(A$) ' Get Keypress IF UCASE$(A$)="N" THEN EXIT SUB ' OverWrite ? END IF LOCATE 25,1 COLOR 14,0 ? " Saving File. Please wait! "; ON ERROR GOTO BasSaveError ' Error Checking Enabled OPEN File$ FOR OUTPUT AS #1 ' Open File LineNumber=10000 ' Initialize Line Number CALL NewLine(Lin$,LineNumber) Lin$=Lin$+" KEY OFF : CLS " PRINT #1,Lin$ ' Output Line Lin$="" ' Clear Variable Attr=256 FOR LinePointer=0 TO 22 ' Save 23 lines TempText$="" DEF SEG=%VideoSegment+(LinePointer*10) ' Def Seg for start of each line ChrPointer=0 CALL NewLine(Lin$,LineNumber) DO IF Attr <> PEEK(ChrPointer+1) THEN ' Did color change ? CALL NewBasicColor(ChrPointer,Attr,LineNumber,Lin$,TempText$) END IF TempText$=TempText$+CHR$(PEEK(ChrPointer))' TextString To Be Output ChrPointer=ChrPointer+2 LOOP UNTIL ChrPointer > 159 IF LEN(TempText$) > 0 THEN CALL OutputText(LineNumber,Lin$,TempText$) NEXT LinePointer ' Next Line CALL NewLine(Lin$,LineNumber) Lin$=Lin$+" COLOR 7,0 : RETURN" PRINT #1, Lin$ Close #1 ' Close and Exit ON ERROR GOTO 0 ' Disable Error Checking EXIT SUB ' Saving Errors Come here BasSaveError: CLOSE #1 ' Close File RESUME BasError BasError: ON ERROR GOTO 0 ' Disable Error Checking CALL DiskError(1) ' Print Error Message END SUB ' BasicSave SUB NewLine(Lin$,LineNumber) Lin$="" Lin$=MID$(STR$(LineNumber),2,5) LineNumber=LineNumber+10 END SUB ' NewLine SUB NewBasicColor(ChrPointer,Attr,LineNumber,Lin$,TempText$) LOCAL Blink,TempAttr,Back,Fore IF LEN(TempText$) > 0 THEN CALL OutputText(LineNumber,Lin$,TempText$) Blink=0 Attr=PEEK(ChrPointer+1) ' Get Attribute TempAttr=Attr ' Into TempAttr IF TempAttr>128 THEN ' Test for Blinking Char TempAttr=TempAttr-128 Blink=1 END IF Back=TempAttr\16 ' Background Fore=TempAttr-(Back*16) ' ForeGround IF Blink=1 THEN Fore=Fore+16 ' Blinking ? Lin$=Lin$+" COLOR " + STR$(Fore) + "," + STR$(Back) + " :" END SUB ' NewBasicColor SUB OutputText(LineNumber,Lin$,TempText$) LOCAL CurrentCharacter,Test$,StrFlag,NewLine Lin$=Lin$+" PRINT " NewLine=0 CurrentCharacter=1 DO ' Test for repeating character Test$=MID$(TempText$,CurrentCharacter,1) Count=1 FOR T=CurrentCharacter+1 TO LEN(TempText$) IF Test$ <> MID$(TempText$,T,1) THEN EXIT FOR Count=Count+1 NEXT T IF Count > 12 THEN Lin$=Lin$ + "STRING$(" + STR$(Count) + "," + STR$(ASC(Test$)) + ")" StrFlag=1 NewLine =1 GOTO NextChar END IF ' Test for character 34 (quote) IF Count < 13 AND Test$=CHR$(34) THEN Lin$=Lin$ + "STRING$(" + STR$(Count) + "," + STR$(ASC(Test$)) + ")" StrFlag=1 NewLine =1 GOTO NextChar END IF ' Test for characters 26 (end of file) IF Count < 13 AND Test$ = CHR$(26) THEN Lin$=Lin$ + "STRING$(" + STR$(Count) + "," + STR$(ASC(Test$)) + ")" StrFlag=1 NewLine =1 GOTO NextChar END IF IF Count < 13 THEN IF RIGHT$(Lin$,1)=CHR$(34) THEN Lin$=LEFT$(Lin$,(LEN(Lin$)-1)) IF RIGHT$(Lin$,1)=")" AND StrFlag=1 THEN Lin$=Lin$+CHR$(34) StrFlag=0 END IF IF NewLine = 0 THEN Lin$=Lin$+CHR$(34) NewLine=1 END IF Lin$=Lin$+MID$(TempText$,CurrentCharacter,Count) + CHR$(34) END IF NextChar: CurrentCharacter=CurrentCharacter+Count LOOP UNTIL CurrentCharacter > LEN(TempText$) Lin$=Lin$ + ";" PRINT #1,Lin$ ' Output Text String CALL NewLine(Lin$,LineNumber) ' New Line TempText$="" ' Clear TempText$ END SUB ' OutputText ' FileCheck File Checking routine SUB FileCheck(FileName$,FileSize) ON ERROR GOTO FileError ' Enable Error Checking OPEN "R",#9,FileName$,1 : FileSize=LOF(9) : CLOSE 9 IF FileSize=0 THEN KILL FileName$ ' File Did NOT Exist ON ERROR GOTO 0 ' Disable Error Checking EXIT SUB RouteErrorHere: ON ERROR GOTO 0 EXIT SUB FileError: CALL DiskError(4) ' Disk Error CLOSE 9 : FileSize=0 RESUME RouteErrorHere END SUB ' FileCheck ' DiskError prints error to screen ' Type: ' 1=Not enough rooom ' 2=File not found ' 3=Not a SCR file ' 4=Disk Error ' 5=No Help File ' 6=Illegal Path SUB DiskError(Type) SHARED WSmall(),WErrData() CALL OPENWINDOW(WSmall(),WErrData()) ' Open Window COLOR 15,4 LOCATE 12,28,0 IF Type = 1 THEN ?" Not enough room on drive" IF Type = 2 THEN ?" File not found " IF Type = 3 THEN ?" Not a SCREEN format file" IF Type = 4 THEN ?" Disk Error " IF Type = 5 THEN ?"File SCREEN.HLP not found" IF Type = 6 THEN ?" Error:Not a legal path " WHILE NOT INSTAT : WEND CALL CLOSEWINDOW(WSmall(),WErrData()) ' Close Window END SUB ' DiskError SUB ChangePath SHARED WSmall(),WPathData(),Path$,GoodPath$ LOCAL NewPath$ NewPath$=Path$ CALL OPENWINDOW(WSmall(),WPathData()) ' Open Path Window LOCATE 6,30 : COLOR 14,0 ?" Path " LOCATE 7,18,1,1,7 ? LEFT$(Path$,29); ' Print Current Path LOCATE 7,18 DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) OR A$=CHR$(13) THEN ' Escape OR Exit ? CALL CLOSEWINDOW(WSmall(),WPathData()) ' Close Window LOCATE 1,1,0 EXIT SUB ' and EXIT END IF LOOP UNTIL INSTR(GoodPath$,A$) <> 0 ' Wait for Legal Character NewPath$=A$ ' Set Variable DO LOCATE 7,18 : ? SPACE$(30) LOCATE 7,18 : ? RIGHT$(NewPath$,29); CALL Getkey(A$) ' Get Next Character IF A$=CHR$(27) THEN ' Escape ? LOCATE 1,1,0 CALL CLOSEWINDOW(WSmall(),WPathData()) ' Close Window EXIT SUB END IF IF INSTR(GoodPath$,A$) <> 0 THEN ' Check for Legal Character NewPath$=NewPath$+A$ END IF IF A$=CHR$(8) THEN ' Check for BackSpace IF LEN(NewPath$) > 0 THEN NewPath$=LEFT$(NewPath$,(LEN(NewPath$)-1)) END IF ' Maximum length of 66 IF LEN(NewPath$) > 66 THEN NewPath$=LEFT$(NewPath$,66) LOOP UNTIL A$=CHR$(13) ' Wait for Return CALL CLOSEWINDOW(WSmall(),WPathData()) ' Close Window LOCATE 1,1,0 IF LEN(NewPath$) = 1 THEN IF NewPath$="\" THEN NewPath$="A:\" IF LEN(NewPath$) = 1 THEN NewPath$=NewPath$+":\" IF LEN(NewPath$) = 2 THEN NewPath$=NewPath$+"\" IF FNPath(NewPath$)=0 THEN CALL DiskError(6) : NewPath$=Path$ ' Error Path$=NewPath$ ' Set Path$ END SUB ' ChangePath ' FNPath returns 0 if PATH doesn't exist ' 1 if it does DEF FNPath(NewPath$) LOCAL Path ON ERROR GOTO PathError ' Enable Error Checking Path=1 CHDIR NewPath$ ' Change Directory IF ERR=0 THEN CHDIR NewPath$ ' Error ? GOTO FinishPath PathError: Path=0 ' Set Error Flag RESUME NEXT FinishPath: ON ERROR GOTO 0 ' Disable Error Checking FNPath=Path END DEF ' FNPath SUB Directory SHARED Path$,Mask$ LOCAL TempPath$ CALL ChangeMask(Stat) ' Check Current Mask IF Stat THEN EXIT SUB ' EXIT ? TempPath$=Path$ IF RIGHT$(TempPath$,1) <> "\" THEN TempPath$=TempPath$+"\" TempPath$=TempPath$+Mask$ SCREEN 0,0,2,2 ' Screen 2 for Directory COLOR 14,1 CLS ON ERROR GOTO DirectoryError ' Error Checking LOCATE 1,1 : ? TempPath$ FILES TempPath$ ' Print Directory ?:?"Press any key to continue." WHILE NOT INSTAT : WEND ' Wait for Keypress SCREEN 0,0,0,0 ' and Return GOTO DirectDone DirectoryError: ' Errors come here ?"No files matching ";TempPath$ RESUME NEXT Directdone: ON ERROR GOTO 0 ' Disable Error Checking END SUB ' Directory SUB ChangeMask(Stat) SHARED Mask$,GoodMask$,WSmall(),WMaskData() Stat = 0 NewMask$=Mask$ CALL OPENWINDOW(WSmall(),WMaskData()) ' Open Mask Window LOCATE 7,22 : COLOR 14,0 ?" MASK " LOCATE 8,19,1,1,7 ? Mask$; ' Print Current Mask LOCATE 8,19 DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) OR A$=CHR$(13) THEN ' Escape OR Exit ? CALL CLOSEWINDOW(WSmall(),WMaskData()) ' Close Window LOCATE 1,1,0 IF A$=CHR$(27) THEN Stat = 1 ' Set Flag EXIT SUB ' EXIT END IF LOOP UNTIL INSTR(GoodMask$,A$) <> 0 NewMask$=A$ ' Set Variable String DO LOCATE 8,19 : ? SPACE$(12) ' Clear Line LOCATE 8,19 : ? NewMask$; ' Print New Mask CALL Getkey(A$) IF A$=CHR$(27) THEN CALL CLOSEWINDOW(WSmall(),WMaskData()) ' Close Mask Window LOCATE 1,1,0 Stat=1 EXIT SUB END IF ' Check for Legal Characters IF INSTR(GoodMask$,A$) <> 0 THEN NewMask$=NewMask$+A$ IF A$=CHR$(8) THEN ' BackSpace IF LEN(NewMask$) > 0 THEN NewMask$=LEFT$(NewMask$,(LEN(NewMask$)-1)) END IF ' Maximum Than 12 characters IF LEN(NewMask$) > 11 THEN NewMask$=LEFT$(NewMask$,12) LOOP UNTIL A$=CHR$(13) ' Wait for Return LOCATE 1,1,0 Mask$=NewMask$ CALL CLOSEWINDOW(WSmall(),WMaskData()) ' Close Mask Window END SUB ' ChangeMask DOSSHELL: CALL CLOSEWINDOW(WLarge(),WFilesData()) ' Close Files Window SCREEN 0,0,3,3 ' Screen 3 for SHELL CLS ON ERROR GOTO ErrorShell ' Error Checking SHELL SCREEN 0,0,0,0 ' Return ON ERROR GOTO 0 ' Disable Error Checking GOTO START ' Return ErrorShell: RESUME NEXT GOTO START ' ********************** COLORS ******************** ' New Background COLOR SUB Colors(CurrentFore,CurrentBack) SHARED WBack(),WBackData() LOCAL T,NewBack LOCATE 1,1,0 ' Hide Cursor CALL OPENWINDOW(WBack(),WBackData()) ' Open Color Window COLOR 14,0 ' Set-up Color Menu LOCATE 2,12:?" Choose" LOCATE 3,12:?" BackGround" COLOR 11,0 LOCATE 4,11:?"╟──────────────╢" FOR T=0 TO 7 : LOCATE T+5,14 : COLOR T,T ?" " NEXT T COLOR 14,0 : LOCATE 5+CurrentBack,13 :?">" NewBack=CurrentBack DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) THEN ' ESCAPE ? CALL CLOSEWINDOW(WBack(),WBackData()) ' Close Color Window EXIT SUB ' and EXIT END IF IF LEFT$(A$,1)=CHR$(0) THEN ' Extened Key ? CALL Extkey(A$,K) ' Get Code IF K=72 THEN ' MOVE UP LOCATE 5 + NewBack,13 :?" " IF NewBack = 0 THEN NewBack = 8 NewBack = NewBack-1 LOCATE 5+NewBack,13 :?">" END IF IF K=80 THEN ' MOVE DOWN LOCATE 5 + NewBack,13 :?" " IF NewBack = 7 THEN NewBack = -1 NewBack = NewBack + 1 LOCATE 5+NewBack,13 :?">" END IF END IF IF A$=CHR$(13) THEN ' RETURN ? CurrentBack=NewBack CALL ForeColor(CurrentFore,CurrentBack,Stat) IF Stat = 1 THEN EXIT LOOP ' Flag for ForeGround Color END IF LOOP CALL CLOSEWINDOW(WBack(),WBackData()) ' Close Color Window END SUB ' Colors ' ' New Foreground COLOR ' SUB ForeColor(CurrentFore,CurrentBack,Stat) SHARED WFore(),WForeData() LOCAL T,NewFore,BlinkFore BlinkFore=0 Stat = 0 ' Set Flag CALL OPENWINDOW(WFore(),WForeData()) ' Open ForeGround Color Window COLOR 14,0 ' Set-up Menu LOCATE 2,28:?" Choose" LOCATE 3,28:?" ForeGround" COLOR 11,0 LOCATE 4,27:?"╟────────────────────────────╢" FOR T=0 TO 15 : LOCATE T+5,30 : COLOR T,CurrentBack ?" Foreground "; : COLOR 11,0 : ?" "; COLOR T+16,CurrentBack : ?" Foreground " NEXT T COLOR 14,0 NewFore=CurrentFore IF NewFore > 15 THEN NewFore=NewFore-16 BlinkFore=14 END IF LOCATE 5+NewFore,29+BlinkFore :?">" DO CALL Getkey(A$) ' Get Keypress IF A$=CHR$(27) THEN ' ESCAPE ? CALL CLOSEWINDOW(WFore(),WForeData()) ' Close Window EXIT SUB ' and EXIT END IF IF LEFT$(A$,1)=CHR$(0) THEN ' Extended Key ? CALL Extkey(A$,K) ' Get Code IF K=72 THEN ' MOVE UP LOCATE 5+NewFore,29+BlinkFore :?" " IF NewFore = 0 THEN NewFore = 16 NewFore = NewFore-1 LOCATE 5+NewFore,29+BlinkFore :?">" END IF IF K=75 THEN ' MOVE LEFT IF BlinkFore=0 THEN EXIT IF LOCATE 5+NewFore,29+BlinkFore :?" " BlinkFore=0 LOCATE 5+NewFore,29+BlinkFore :?">" END IF IF K=77 THEN ' MOVE RIGHT IF BlinkFore=14 THEN EXIT IF LOCATE 5+NewFore,29+BlinkFore :?" " BlinkFore=14 LOCATE 5+NewFore,29+BlinkFore :?">" END IF IF K=80 THEN ' MOVE DOWN LOCATE 5+NewFore,29+BlinkFore :?" " IF NewFore = 15 THEN NewFore = -1 NewFore = NewFore + 1 LOCATE 5+NewFore,29+BlinkFore :?">" END IF END IF LOOP UNTIL A$=CHR$(13) ' Wait for Return CurrentFore=NewFore ' Set Variable IF BlinkFore=14 THEN CurrentFore=CurrentFore+16 Stat = 1 ' Set Flag CALL CLOSEWINDOW(WFore(),WForeData()) ' Close Window END SUB ' ForeColor $INCLUDE "INIT.INC"