'===========================================================================
' Subject: MISCELLANEOUS ROUTINES            Date: 01-12-97 (17:42)       
' Author:  Xtrance Coders Alliance           Code: QB, PDS                
' Origin:  harrys@castel.nl                Packet: LIBRARY.ABC
'===========================================================================
DEFINT A-Z
'       This program is made by yours Mr. SN()W From
'
'               Xtance Coders Alliance 1997
'
'       E-mail: Mrsnow@freemail.nl
'       or
'       harryst@castel.nl
'
' Please send mail if you use any thing of this or if you have any comments
'
' For All BASIC Code from William Yu 1997
'
' --------------------------------------------------------------------------




DECLARE SUB Linein (LineColor%)
DECLARE SUB BACKPrint (Tekst$, HKleur%, wachtt%, keer%)
DECLARE SUB Capslock ()
DECLARE SUB CMosRestore (File$)
DECLARE SUB CMosSAVE (File$)
DECLARE SUB ComeTOgeter (Tekst$, HKleur%, wachtt%, keer%)
DECLARE SUB FLDEdit (FRow%, FCol%, FLength%, FFore%, FBack%, FRKey%, FTemp$)
DECLARE SUB Scroll ()
DECLARE SUB LichtKrant (Tekst$, Regel%, BKleur%, FKleur%)
DECLARE SUB BackShowGround (Tekst$)
DECLARE SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%)
DECLARE SUB PassWordMenu (PassWord$, Plijn%, PRow%, BKleur%, FKleur%, Tekst$, WrongDelay, GOOD)
DECLARE SUB GOODPaSSWoRD ()
DECLARE SUB Sterren ()
DECLARE FUNCTION BeeldSchermKleur! ()
DECLARE SUB LicktKrant (Tekst$, Regel%, BKleur%, FKleur%)
DECLARE SUB wacht ()
DECLARE SUB ShowGif (File$)
DECLARE SUB ShowKlok ()
DECLARE SUB s.TekenKlok ()
DECLARE SUB s.Wijzers (Seconde$)
DECLARE SUB LineOut (LineColor%)
DECLARE SUB DELAYLINE (secs!)
DECLARE FUNCTION IS4DOS% ()
DECLARE FUNCTION DeleteDiskID% (drive$)
DECLARE FUNCTION RenameDiskID% (drive$, OldDiskID$, NewDiskID$)
DECLARE SUB GetDTAAddr (Segment%, Offset%)
DECLARE FUNCTION SetDiskID% (drive$, VolumeName$)
DECLARE FUNCTION Lo% (IntegerVar%)
DECLARE FUNCTION GetDiskID$ (drive$)
DECLARE FUNCTION Selecterror$ (Whitch%)
DECLARE SUB ViewFile (FileName$)
DECLARE FUNCTION DiskDrive$ ()
DECLARE FUNCTION CodeToets! ()
DECLARE FUNCTION gameaddaptor% ()
DECLARE FUNCTION HarDDisK$ ()
DECLARE FUNCTION ChkANSI% ()
DECLARE FUNCTION Path$ ()
DECLARE FUNCTION ProgramName$ ()
DECLARE FUNCTION BestandAanwezig% (bestand$)
DECLARE SUB BinCopy (Bestand1$, Bestand2$, FileCopyShow%, Regel%, Waar%, BKleur%, FKleur%, Car%)
DECLARE SUB Delay (del%, keer%)
DECLARE SUB DrawBox (UpRow%, LtCol%, LoRow%, RtCol%)
DECLARE SUB pause (ticks%)
DECLARE SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%)
DECLARE SUB GetDefaultDrive ()
DECLARE SUB GetDriveInfo ()
DECLARE SUB GetMEMoryInfo ()
DECLARE SUB fileread (FileName$, linecount%, a$())
DECLARE FUNCTION keycode% ()


TYPE ExtendedFCBRecord
	ExtFCB   AS STRING * 1
	Res1     AS STRING * 5
	Attr     AS STRING * 1
	drive    AS STRING * 1
	Name1    AS STRING * 11
	Unused1  AS STRING * 5
	Name2    AS STRING * 11
	Unused2  AS STRING * 9
END TYPE

TYPE StarType
  Angle AS INTEGER
  Speed AS INTEGER
  Brite AS INTEGER
  RealX AS INTEGER
  RealY AS INTEGER
  Dis   AS INTEGER
END TYPE

DEFINT A-Z
CONST False = 0
CONST true = -1

'$INCLUDE: 'QB.BI'
DIM SHARED inreg AS RegType
DIM SHARED outreg AS RegType
DIM SHARED InRegs AS RegType, OutRegs AS RegType
DIM SHARED drive, psp

TYPE Fixed
  Str AS STRING * 16384                          'kopieerbuffer
END TYPE

'----------------------------------
'BACKPrint "Erik", 7, 1, 1
'----------------------------------
'BackShowGround " TCP_LIB "
'----------------------------------
'i = BeeldSchermKleur
'IF i = 1 THEN PRINT "You got a COLOR monitor" ELSE PRINT "you got a Black/White monitor "
'----------------------------------
'BinCopy "C:\COMMAND.COM", "C:COM.COM", 1, 4, 10, 7, 0, 34
'----------------------------------
'Capslock 'if on then out or if out then on
'----------------------------------
'i = ChlAnsi
'IF i = 1 THEN PRINT "ANSi installed" ELSE PRINT "ANSi not installed"
'----------------------------------
'CMosSAVE "CMOS.DAT" 'Save CMOS in CMOS.DAT
'----------------------------------
'CMosRestore "CMOS.DAT" 'Restore CMOS
'----------------------------------
'ComeTOgeter "erik is okee", 1, 30, 100
'----------------------------------
'DELAY is using by COmeTOGeter and some other SUBS
'Also DELAYLINE
'DrawBox is using by EXAND
'FileRead is using by ViewFile
'GetDTAAddr <---- ???? for some sub
'GOODPaSSWoRD Used by PaSSWoRDMeNu
'GetFTime <--- Get the time from a file
'LO is used by ???
'Pause is used by EXPAND
'----------------------------------
'i = DeleteDiskID%("C:") 'Delete the C: LABEL
'----------------------------------
'Expand 1, 10, 20, 30
'----------------------------------
'FLDEdit 10, 10, 30, 7, 0, 10, a$
'PRINT a$ '< ----you; see; what; you; typted
'----------------------------------
'i = gameaddaptor
'IF i = 1 THEN PRINT "You got a gameaddaptor" ELSE PRINT "NO gameaddaptor installed"
'----------------------------------
'GetDefaultDrive
'PRINT CHR$(drive + 64) + ":\"
'----------------------------------
'i$ = GetDiskID("C:")
'PRINT i$ '< ---Your; drive; LABEL
'----------------------------------
'GetDefaultDrive
'GetDriveInfo '<--- get info about the drive
'----------------------------------
'GetMEMoryInfo '<--- get info about the drive
'----------------------------------
'i$ = HarDDisK$
'PRINT i$ '<-- see what for sort of drive you got
'----------------------------------
'i = IS4DOS
'IF i = 1 THEN PRINT "4DOS is INSTALLED" ELSE PRINT "4DOS is not installed"
'----------------------------------
'kee = keycode
'PRINT kee '< ---Look whit toets you hat toutched
'----------------------------------
'LichtKrant "erik is alwijs okee", 4, 6, 7
'----------------------------------
'LineOut 4 '<---- You will see
'It's very nice
'Linein 4 '<--- this go's in
'----------------------------------
'PassWordMenu "erik", 10, 10, 7, 1, "Please enter the PASSWORD", 1000 * 10, 1
'You must type 'erik'
'----------------------------------
'i$ = Path$
'PRINT i$ '<---you wil see the Path
'----------------------------------
'i$ = ProgrammName$
'PRINT i$ '<--- you wil see the name of the .EXE programm
'----------------------------------
'REBOOT '<--- wil reboot your system
'----------------------------------
'b$ = GetDiskID$("C:")
'i = RenameDiskID("C:", b$, "TCP_LIB")' <--- rename the label to TCP_LIB
'----------------------------------
'ResoreScreen Save$ <---- First use SaveScreen Save$
'----------------------------------
'Scroll '<---- Scroll the screen up and back down
'----------------------------------
'i$ = Selecterror$(75)
'PRINT i$ '<---it's print PATH/File acces error
'----------------------------------
'i = SetDiskID("C:", "TCP_LIB")
'----------------------------------
'ShowGif "C:\PROGRAMM\QBASIC\FOR_DEMO\GRAfisch\NEON.GIF"
'----------------------------------
'ShowKlok '<--- Shows a NICE clock
'----------------------------------
'Sterren '<--- Prints stars on the screen that walks to you
'----------------------------------
'ViewFile "C:\autoexec.bat"
'----------------------------------

SUB BACKPrint (Tekst$, HKleur%, wachtt, keer)
lijn = CSRLIN: row = POS(0)

FOR i = LEN(Tekst$) TO 1 STEP -1
a = ASC(MID$(Tekst$, i, 1))
IF a >= 65 AND a <= 90 THEN COLOR HKleur%, 0 ELSE COLOR 7, 0
IF a = 45 THEN COLOR 3, 0: IF a = 61 THEN COLOR HKleur%, 0
LOCATE lijn, row + i: PRINT MID$(Tekst$, i, 1)
Delay wachtt, keer
NEXT

END SUB

SUB BackShowGround (Tekst$)
FOR i = 80 TO 1990 STEP INT(LEN(Tekst$))
FOR t = 1 TO LEN(Tekst$)
PRINT MID$(Tekst$, t, 1);
NEXT t, i


END SUB

DEFSNG A-Z
FUNCTION BeeldSchermKleur
DEF SEG = 0
IF PEEK(&H463) = &HB4 THEN BeeldSchermKleur = 0 ELSE BeeldSchermKleur = 1
END FUNCTION

DEFINT A-Z
SUB BinCopy (Bestand1$, Bestand2$, FileCopyShow%, Regel%, Waar%, BKleur%, FKleur%, Car%)

Add% = 0  '0 = overschrijven. -1 = Toevoegen
CopyDate% = 1 '0 = huidige datum. -1 = datum van bronbestand
REDIM Buffer(0) AS Fixed                         ' fixed string in far heap

f1% = FREEFILE                                   ' handle #F1%
OPEN Bestand1$ FOR BINARY AS #f1% LEN = 4096     ' open bronbestand

f2% = FREEFILE                                   ' handle #F2%
IF NOT Add% THEN                                 ' overschrijven
  OPEN Bestand2$ FOR OUTPUT AS #f2%              ' voor alle zekerheid...
  CLOSE #f2%                                     '
  KILL Bestand2$                                 ' wissen
END IF

OPEN Bestand2$ FOR BINARY AS #f2% LEN = 4096     ' open doelbestand

IF Add% THEN                                     ' Toevoegen
  TotalBytes& = LOF(f1%) + LOF(f2%)              ' tel op
  SEEK #f2%, LOF(f2%) + 1                        ' append
ELSE
  TotalBytes& = LOF(f1%)
END IF

DO
  GET #f1%, , Buffer(0)                          ' lees dan 16Kb
  IF NOT EOF(f1%) THEN
    PUT #f2%, , Buffer(0)                        ' schrijf naar 2
  ELSE                                           ' hoeveel rest ?
    FOR x% = 1 TO (TotalBytes& - LOF(f2%)) STEP 4096
	IF TotalBytes& - LOF(f2%) >= 4096 THEN     ' blokken van 4Kb
	Temp$ = MID$(Buffer(0).Str, x%, 4096)
	ELSE
	Temp$ = MID$(Buffer(0).Str, x%, (TotalBytes& - LOF(f2%)))
	END IF
	PUT #f2%, , Temp$                          ' schrijf rest
    
    NEXT x%
  END IF
COLOR 7, 0
IF FileCopyShow = 1 THEN
COLOR BKleur%, FKleur%
LOCATE Regel%, Waar%
PRINT STRING$(INT(LOF(f2%) / (LOF(f1%) / 100)) / 2, Car%); '219
LOCATE Regel% + 1, Waar% + 20: PRINT INT(LOF(f2%) / (LOF(f1%) / 100)); "% Done  "
END IF

LOOP UNTIL EOF(f1%)
CLOSE 1, 2
END SUB

SUB Capslock
DEF SEG = 0
status% = PEEK(&H417)
POKE &H417, (status% XOR &H40)

END SUB

FUNCTION ChkANSI
 
inreg.ax = &H1A00
INTERRUPT &H2F, inreg, outreg
 
SELECT CASE outreg.ax MOD 256
	CASE 0
		ChkANSI = 0
	CASE 255
		ChkANSI = 1
END SELECT
 
 
END FUNCTION

SUB CMosRestore (File$)
DIM Byte AS STRING * 1
	 
OPEN File$ FOR BINARY AS #1
FOR CMOS = 1 TO LOF(1)
	  OUT &H70, CMOS - 1
		  GET #1, , Byte
	  OUT &H71, ASC(Byte)
NEXT: CLOSE 1

END SUB

SUB CMosSAVE (File$)
DIM Byte AS STRING * 1
	
OPEN File$ FOR OUTPUT AS #1
FOR CMOS = &H0 TO &H3F
	  OUT &H70, CMOS
		  DByte% = INP(&H71)
	  PRINT #1, CHR$(DByte%);
NEXT: CLOSE 1

END SUB

SUB ComeTOgeter (Tekst$, HKleur%, wachtt, keer)
lijn = CSRLIN + 1: row = POS(0)
Einde = LEN(Tekst$) / 2
AStart = 1
BStart = LEN(Tekst$)
FOR i = 1 TO Einde
GOSUB PrintA
GOSUB PrintB
AStart = AStart + 1
BStart = BStart - 1

Delay wachtt, keer
NEXT i
EXIT SUB


PrintA:
a = ASC(MID$(Tekst$, AStart, 1))
IF a >= 65 AND a <= 90 THEN COLOR HKleur%, 0 ELSE COLOR 7, 0
IF a = 45 THEN COLOR 3, 0: IF a = 61 THEN COLOR HKleur%, 0
LOCATE lijn, row + AStart: PRINT MID$(Tekst$, AStart, 1)
RETURN


PrintB:
a = ASC(MID$(Tekst$, BStart, 1))
IF a >= 65 AND a <= 90 THEN COLOR HKleur%, 0 ELSE COLOR 7, 0
IF a = 45 THEN COLOR 3, 0: IF a = 61 THEN COLOR HKleur%, 0
LOCATE lijn, row + BStart: PRINT MID$(Tekst$, BStart, 1)

RETURN

END SUB

SUB Delay (del, keer)
FOR k = 1 TO keer
FOR i = 1 TO del * 10
NEXT i
NEXT k

END SUB

SUB DELAYLINE (secs!)

    begin! = TIMER
    DO
    LOOP UNTIL TIMER - begin! > secs!
END SUB

FUNCTION DeleteDiskID% (drive$)

	DIM EFCB AS ExtendedFCBRecord
	DIM InRegsX AS RegTypeX, OutRegsX AS RegTypeX

	EFCB.ExtFCB = CHR$(&HFF)  'Set EFCB flag
	EFCB.Attr = CHR$(&H8)     'Vol label attribute
	EFCB.drive = CHR$(ASC(drive$) - 64)
	EFCB.Name1 = "*.*        "

	InRegsX.ax = &H1300        'Call find first FCB
	InRegsX.ds = VARSEG(EFCB)  'Load DS:DX with
	InRegsX.dx = VARPTR(EFCB)  'address of EFCB
	CALL INTERRUPTX(&H21, InRegsX, OutRegsX)

'Set error codes

	IF Lo(OutRegsX.ax) = 0 THEN     'Successful
		DeleteDiskID = -1 'True
	ELSE
		DeleteDiskID = 0  'False
	END IF

END FUNCTION

 SUB DrawBox (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    Wide% = (RtCol% - LtCol%) - 1
    LOCATE UpRow%, LtCol%
    PRINT CHR$(201); STRING$(Wide%, CHR$(205)); CHR$(187);
    FOR i% = UpRow% + 1 TO LoRow% - 1
	LOCATE i%, LtCol%
	PRINT CHR$(186); SPACE$(Wide%); CHR$(186);
    NEXT i%
    LOCATE LoRow%, LtCol%
    PRINT CHR$(200); STRING$(Wide%, CHR$(205)); CHR$(188);
 END SUB

 SUB Expand (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    RowCenter% = ((LoRow% - UpRow%) / 2) + UpRow%
    ColCenter% = ((RtCol% - LtCol%) / 2) + LtCol%
    UprRow% = RowCenter%: LeftCol% = ColCenter%
    LwrRow% = RowCenter%: RghtCol% = ColCenter%
    DO
	LeftCol% = LeftCol% - 1
	RghtCol% = RghtCol% + 1
	IF LeftCol% < LtCol% THEN LeftCol% = LtCol%
	IF RghtCol% > RtCol% THEN RghtCol% = RtCol%
	DrawBox UprRow%, LeftCol%, LwrRow%, RghtCol%
	IF LeftCol% = LtCol% AND RghtCol% = RtCol% THEN EXIT DO
    LOOP
    DO
	UprRow% = UprRow% - 1
	LwrRow% = LwrRow% + 1
	IF UprRow% < UpRow% THEN UprRow% = UpRow%
	IF LwrRow% >= LoRow% THEN LwrRow% = LoRow%
	DrawBox UprRow%, LeftCol%, LwrRow%, RghtCol%
	IF UprRow% = UpRow% AND LwrRow% = LoRow% THEN EXIT DO
	pause 1
    LOOP
    Shadow UpRow%, LtCol%, LoRow%, RtCol%
 END SUB

SUB fileread (FileName$, linecount%, a$()) STATIC
 filenumber% = FREEFILE
 OPEN FileName$ FOR INPUT AS filenumber%
 FOR i% = LBOUND(a$) TO UBOUND(a$)
  LINE INPUT #filenumber%, a$(i%)
  linecount% = i%
  IF EOF(filenumber%) THEN EXIT FOR
 NEXT i%
 IF NOT EOF(filenumber%) THEN linecount% = -1
END SUB

DEFSNG A-Z
SUB FLDEdit (FRow%, FCol%, FLength%, FFore%, FBack%, FRKey%, FTemp$) STATIC

'  Set boolean values
		CONST true = -1
		CONST False = 0

'  Set color, ephasize field, insert string, and set cursor
		FSet% = FCol% - 1
		COLOR FFore%, FBack%
		LOCATE FRow%, FCol%, 0
		PRINT FTemp$; SPACE$(FLength% - LEN(FTemp$));
		LOCATE FRow%, FCol%, 1

'  Check FRKey% and set page key functions
		IF FRKey% THEN
			PageSet% = true
		ELSE
			PageSet% = False
		END IF

'  Initialize return key code, stop, reset insert mode
		FRKey% = False
		FStop% = False
		FInsert% = False

'  Set Editor Output string to new Input string
		Fout$ = FTemp$

'  Start Parsing
		DO UNTIL FStop%

'  Sound alarm if called for
			IF Alarm% THEN
				SOUND 1000, 1
				SOUND 1500, 2
				SOUND 500, 1
				Alarm% = False
			END IF

'  Get a key to parse
			FIn$ = ""
			DO
			FIn$ = INKEY$
			LOOP WHILE FIn$ = ""

'  Start by parsing length of key string
			SELECT CASE LEN(FIn$)

'  Check for extended key, strip leading zero
				CASE 2
				FIn$ = RIGHT$(FIn$, 1)

'  Use ASCII value to select
					SELECT CASE ASC(FIn$)

'  Cursor Right
						CASE 77
							IF POS(0) < FSet% + (LEN(Fout$) + 1) THEN
								LOCATE , POS(0) + 1
							ELSE
								Alarm% = true
							END IF

'  Cursor Left
						CASE 75
							IF POS(0) > FSet% + 1 THEN
								LOCATE , POS(0) - 1
							ELSE
								Alarm% = true
							END IF

'  Delete
						CASE 83
							IF POS(0) - FSet% <= LEN(Fout$) THEN
								Shift$ = MID$(Fout$, (POS(0) - FSet%) + 1)
								Fout$ = LEFT$(Fout$, ((POS(0) - FSet%) - 1)) + Shift$
								FTempPos% = POS(0)
								LOCATE , , 0
								PRINT MID$(Fout$, POS(0) - FSet%); CHR$(32);
								LOCATE , FTempPos%, 1
							ELSE
								Alarm% = true
							END IF

'  Insert
						CASE 82
							IF FInsert% = False THEN
								FInsert% = true
								LOCATE , , , 0, 7
							ELSEIF FInsert% = true THEN
								FInsert% = False
								LOCATE , , , 7, 7
							END IF

'  Up, Down, PgUp, PgDn, Home, End
						CASE 59 TO 68, 71, 72, 73, 79, 80, 81
							IF PageSet% THEN
								FRKey% = ASC(FIn$)
								FStop% = true
							ELSE
								Alarm% = true
							END IF

'  Any other key is illegal so set alarm and loop
						CASE ELSE
							Alarm% = true

					END SELECT

'  Check for non-extended keys
				CASE 1

'  Use ASCII value to select
					SELECT CASE ASC(FIn$)

'  Backspace
						CASE 8
							IF POS(0) - FSet% > 1 THEN
								IF POS(0) - FSet% > LEN(Fout$) THEN
									Fout$ = LEFT$(Fout$, LEN(Fout$) - 1)
									FTempPos% = POS(0)
									LOCATE , POS(0) - 1, 0
									PRINT CHR$(32);
									LOCATE , FTempPos% - 1, 1
								ELSEIF POS(0) - FSet% <= LEN(Fout$) THEN
									Shift$ = MID$(Fout$, POS(0) - FSet%)
									Fout$ = LEFT$(Fout$, ((POS(0) - FSet%) - 2)) + Shift$
									FTempPos% = POS(0)
									LOCATE , POS(0) - 1, 0
									PRINT MID$(Fout$, POS(0) - FSet%); CHR$(32);
									LOCATE , FTempPos% - 1, 1
								END IF
							ELSE
								Alarm% = true
							END IF

'  Tab
						CASE 9
							IF PageSet% THEN
								FRKey% = ASC(FIn$)
								FStop% = true
							ELSE
								Alarm% = true
							END IF

'  Carriage Return
						CASE 13
							FRKey% = ASC(FIn$)
							FStop% = true

'  Escape
						CASE 27
							FRKey% = ASC(FIn$)
							FStop% = true

'  Check for additional uprintable input
						CASE IS < 32, IS > 125
							Alarm% = true

'  Found printable key
						CASE 32 TO 125

'  If not past end of maximum length take input.
							IF POS(0) <= FSet% + FLength% THEN

'  If position is less than current string length then check for insert
'  mode on and overwrite character if insert off or insert character if on.
								IF POS(0) - FSet% <= LEN(Fout$) THEN

'  Insert mode off?
									IF FInsert% = False THEN
										MID$(Fout$, POS(0) - FSet%, 1) = FIn$
										PRINT FIn$;

'  Insert mode on?
									ELSEIF FInsert% = true THEN

'  Check length of string plus input and take input if less than max lenth.
										IF LEN(Fout$) < FLength% THEN
											Shift$ = MID$(Fout$, POS(0) - FSet%)
											Fout$ = LEFT$(Fout$, (POS(0) - FSet%) - 1) + FIn$ + Shift$
											FTempPos% = POS(0)
											LOCATE , , 0
											PRINT MID$(Fout$, POS(0) - FSet%);
											LOCATE , FTempPos% + 1, 1

'  If string plus input too long sound alarm and return.
										ELSE
											Alarm% = true
										END IF
									END IF

'  If string position greater than current string length then add character.
								ELSEIF POS(0) - FSet% > LEN(Fout$) THEN
									Fout$ = Fout$ + FIn$
									PRINT FIn$;
								END IF

'  Cursor past end of field so input is illegal
							ELSE
								Alarm% = true
							END IF

'  Any other key is illegal so set alarm and loop
						CASE ELSE
							Alarm% = true

					END SELECT

			END SELECT

		LOOP

'  Exit, reset cursor, assign passed variable
		LOCATE , , 0, 7, 7
		FTemp$ = Fout$

	END SUB

DEFINT A-Z
FUNCTION gameaddaptor
   
DEF SEG = 0: GAME.ADAPTER% = PEEK(&H411) AND &H10
IF GAME.ADAPTER% = 0 THEN GAME.ADAPTER$ = "NO" ELSE GAME.ADAPTER$ = "YES --INSTALLED"
IF gameadapter$ = "NO" THEN gameaddaptor = 0 ELSE gameaddaptor = 1

END FUNCTION

SUB GetDefaultDrive

InRegs.ax = &H1900
CALL INTERRUPT(&H21, InRegs, OutRegs)
drive = (OutRegs.ax AND 255) + 1

END SUB

FUNCTION GetDiskID$ (drive$)
	DIM EFCB AS ExtendedFCBRecord
	DIM InRegsX AS RegTypeX, OutRegsX AS RegTypeX

'  Get Address of Data Transfer Area (DTA)

	CALL GetDTAAddr(Segment, Offset)

'  Call the Find First FCB function
'  using the Volume attribute

	EFCB.ExtFCB = CHR$(&HFF)   'Set EFCB flag
	EFCB.Attr = CHR$(&H8)      'Vol label attribute
	EFCB.drive = CHR$(ASC(drive$) - 64)
	EFCB.Name1 = "*.*        "
	InRegsX.ax = &H1100        'Call find first FCB
	InRegsX.ds = VARSEG(EFCB)  'Load DS:DX with
	InRegsX.dx = VARPTR(EFCB)  'address of EFCB
	CALL INTERRUPTX(&H21, InRegsX, OutRegsX)

	GetDiskID$ = ""

	IF Lo(OutRegsX.ax) = 0 THEN  'Successful
		VOL$ = ""
		DEF SEG = Segment       'Set Segment to DTA
		FOR i = Offset + 8 TO Offset + 18
			VOL$ = VOL$ + CHR$(PEEK(i))
		NEXT i
		DEF SEG
		GetDiskID$ = VOL$
	END IF
END FUNCTION

SUB GetDriveInfo

InRegs.ax = &H3600
InRegs.dx = drive
CALL INTERRUPT(&H21, InRegs, OutRegs)
IF OutRegs.ax = &HFFFF THEN
	PRINT "Invalid Drive"
ELSE
	clustersize& = CLNG(OutRegs.ax) * CLNG(OutRegs.cx)
	TotalBytes& = CLNG(OutRegs.dx) * clustersize&
	freebytes& = CLNG(OutRegs.bx) * clustersize&
	PRINT USING "Drive !:"; CHR$(drive + ASC("A") - 1)
	PRINT USING "  ######### bytes total disk space"; TotalBytes&
	PRINT USING "  ######### bytes available on disk"; freebytes&
	PRINT
END IF

END SUB

SUB GetDTAAddr (Segment, Offset)

	DIM InRegsX AS RegTypeX, OutRegsX AS RegTypeX

	InRegsX.ax = &H2F00
	CALL INTERRUPTX(&H21, InRegsX, OutRegsX)
	Segment = OutRegsX.es   'Return address of DTA
	Offset = OutRegsX.bx    'Segment:Offset format

END SUB

SUB GetFTime (Handle%, FTime%, FDate%, Datum$, tijd$)


SHARED InRegsX AS RegTypeX, OutRegsX AS RegTypeX
InRegsX.ax = &H5700
InRegsX.bx = FILEATTR(Handle%, 2)
CALL INTERRUPTX(&H21, InRegsX, OutRegsX)
FTime% = OutRegsX.cx
FDate% = OutRegsX.dx

Adress% = VARPTR(FDate%)
Datum$ = MID$(STR$((PEEK(Adress%) AND &H1F)), 2) + "-"
Datum$ = Datum$ + MID$(STR$((PEEK(Adress% + 1) AND &H1) * 8 + (PEEK(Adress%) AND &HE0) \ 32), 2) + "-"
Datum$ = Datum$ + MID$(STR$(((PEEK(Adress% + 1) AND &HFE) \ 2 + 80) MOD 100), 2)

Adress% = VARPTR(FTime%)
tijd$ = MID$(STR$((PEEK(Adress% + 1) AND &HF8) \ 8), 2) + ":"
tijd$ = tijd$ + MID$(STR$((PEEK(Adress% + 1) AND &H7) * 8 + (PEEK(Adress%) AND &HE0) \ 32), 2) + ":"
tijd$ = tijd$ + MID$(STR$((PEEK(Adress%) AND &H1F) * 2), 2)


END SUB

SUB GetMEMoryInfo

InRegs.ax = &H6200
CALL INTERRUPT(&H21, InRegs, OutRegs)
psp = OutRegs.bx

CALL INTERRUPT(&H12, InRegs, OutRegs)
memsize& = OutRegs.ax * 64&
PRINT USING "  ######### bytes total memory"; CLNG(OutRegs.ax) * 1024&
PRINT USING "  ######### bytes free"; (memsize& - CLNG(psp) + 1&) * 16&
PRINT : PRINT "  Next program will load at "; HEX$(psp); ":0000 hex"
PRINT

END SUB

SUB GOODPaSSWoRD
DONE:
COLOR 2
LOCATE 1, 1
PRINT SPC(8); " ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü "
PRINT SPC(8); " ±±Ûßßßß  ±±Ûß±±Û  ±±Ûß±±Û  ±±Ûß±±Û  ±±Ûßßßß  ±±Ûßßßß   ß±±Ûßß "
PRINT SPC(8); " ±±Û      ±±Û ±±Û  ±±±±±Ûß  ±±±±±Ûß  ±±±±±Ü   ±±Û        ±±Û   "
PRINT SPC(8); " ±±Û      ±±Û ±±Û  ±±Ûß±±Ü  ±±Ûß±±Ü  ±±Ûßßß   ±±Û        ±±Û   "
PRINT SPC(8); " ±±±±±±Ü  ±±±±±±Û  ±±Û ±±Û  ±±Û ±±Û  ±±±±±±Ü  ±±±±±±Ü    ±±Û   "
PRINT SPC(8); "  ßßßßßß   ßßßßßß   ßß  ßß   ßß  ßß   ßßßßßß   ßßßßßß     ßß   "
LOCATE 18, 1
PRINT SPC(4); " ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±±Ü ±±Ü   ±±Ü  ±±±±±±Ü  ±±±±±±Ü  ±±±±±Ü "
PRINT SPC(4); " ±±Ûß±±Û  ±±Ûß±±Û  ±±Ûßßßß  ±±Ûßßßß ±±Û   ±±Û  ±±Ûß±±Û  ±±Ûß±±Û  ±±Ûß±±Û"
PRINT SPC(4); " ±±±±±±Û  ±±±±±±Û  ±±±±±±Ü  ±±±±±±Ü ±±Û   ±±Û  ±±Û ±±Û  ±±±±±Ûß  ±±Û ±±Û"
PRINT SPC(4); " ±±Ûßßßß  ±±Û ±±Û   ßßß±±Û   ßßß±±Û ±±Û±±Ü±±Û  ±±Û ±±Û  ±±Ûß±±Ü  ±±Û ±±Û"
PRINT SPC(4); " ±±Û      ±±Û ±±Û  ±±±±±±Û  ±±±±±±Û  ß±±±±Ûßß  ±±±±±±Û  ±±Û ±±Û  ±±±±±Ûß"
PRINT SPC(4); "  ßß       ßß  ßß   ßßßßßß   ßßßßßß    ßßßß     ßßßßßß   ßß  ßß   ßßßßß "

END SUB

FUNCTION HarDDisK$
DIM regs AS RegTypeX

regs.ax = &H1C00                       'ah=1c al=00
regs.dx = 0                            '0=default, 1=a:,2=b:,etc
CALL INTERRUPTX(&H21, regs, regs)      'use dos
DEF SEG = regs.ds                      'change to returned segment
MediaByte = PEEK(regs.bx)              'Get the byte
DEF SEG                                'get back to basic's segment

IF (regs.ax AND 255) <> &HFF THEN

    SELECT CASE HEX$(MediaByte)
		CASE "F0"
			HarD$ = "3.5 inch DS, 18 sectors or other"
		CASE "F8"
			HarD$ = "Fixed Disk"
		CASE "F9"
			HarD$ = "5.25 in DS, 15 sects or 3.5 in DS, 9 sects"
		CASE "FC"
			HarD$ = "5.25 inch SS, 9 sectors"
		CASE "FD"
			HarD$ = "5.25 inch DS, 9 sectors"
		CASE "FE"
			HarD$ = "5.25 inch SS, 8 sectors"
		CASE "FF"
			HarD$ = "5.25 inch DS, 8 sectors"
		CASE ELSE
			HarD$ = "Unknown Type"
	END SELECT
     
	HarDDisK$ = "Media ID Byte : " + HEX$(MediaByte) + " = " + HarD$
ELSE
	HarDDisK$ = "Error encountered (invalid drive or critical error)"
END IF


END FUNCTION

FUNCTION IS4DOS

a$ = ENVIRON$("COMSPEC")
IF INSTR(a$, "4DOS") THEN ffos = 1 ELSE ffos = 0
SELECT CASE ffos
CASE 0
IS4DOS = 0
CASE ELSE
IS4DOS = 1
END SELECT

END FUNCTION

FUNCTION keycode% STATIC
 DO
 k$ = INKEY$
 LOOP UNTIL k$ <> ""
 keycode% = CVI(k$ + CHR$(0))
END FUNCTION

SUB LichtKrant (Tekst$, Regel%, BKleur%, FKleur%)
COLOR 7
teksten$ = SPACE$(40) + Tekst$ + SPACE$(40)
FOR teken% = 1 TO LEN(teksten$)
    COLOR BKleur%, FKleur%
    LOCATE Regel%, 1
    PRINT MID$(teksten$, teken%, 80)
    wacht
NEXT teken%
END SUB

SUB Linein (LineColor%)
DIM lijnen$(24)
 
    lijnen$(2) = SPACE$(39) + "þ" + SPACE$(2)
    lijnen$(1) = SPACE$(39) + "." + SPACE$(2)
    lijnen$(23) = STRING$(80, "Ä")
    Sp% = 39
    Ln% = 0
    FOR i% = 2 TO 21
	  lijnen$(i%) = SPACE$(Sp%) + STRING$(Ln%, "Ä") + SPACE$(2)
	  Sp% = Sp% - 2
	  Ln% = Ln% + 4
    NEXT i%
 
    COLOR LineColor%, 0
    FOR i% = 1 TO 23
	  LOCATE 13, 1
	  PRINT lijnen$(i%);
	  Delay .03, 1
    NEXT
 
    COLOR 15, LineColor%
    x% = 12
    y% = 13
    FOR i% = 1 TO 13
	  LOCATE y%, 1
	  PRINT STRING$(80, " ");
	  LOCATE x%, 1
	  PRINT STRING$(80, " ");
	  DrawBox x%, 1, y%, 80
	  Delay .03, 1
	  IF x% > 1 THEN x% = x% - 1
	  y% = y% + 1
    NEXT i%
END SUB

SUB LineOut (LineColor%)  '*** By Mark H Butler
DIM lines$(1 TO 24)
 
    lines$(1) = STRING$(80, "Ä")
    Sp% = 2
    Ln% = 76
    FOR i% = 2 TO 21
	  lines$(i%) = SPACE$(Sp%) + STRING$(Ln%, "Ä") + SPACE$(2)
	  Sp% = Sp% + 2
	  Ln% = Ln% - 4
    NEXT i%
    lines$(22) = SPACE$(39) + "þ" + SPACE$(2)
    lines$(23) = SPACE$(39) + "." + SPACE$(2)
 
    COLOR 0, 0
    x% = 1
    y% = 25
    FOR i% = 1 TO 12
	  LOCATE y%, 1
	  PRINT STRING$(80, CHR$(32));
	  LOCATE x%, 1
	  PRINT STRING$(80, CHR$(32));
	  DELAYLINE .03
	  x% = x% + 1
	  y% = y% - 1
    NEXT i%
    COLOR LineColor%, 0
    FOR i% = 1 TO 23
	  LOCATE 13, 1: PRINT lines$(i%);
	  DELAYLINE .03
    NEXT i%
    COLOR 7
    CLS
END SUB

FUNCTION Lo (IntegerVar)
	Lo = IntegerVar MOD 256
END FUNCTION

SUB PassWordMenu (PassWord$, Plijn%, PRow%, BKleur%, FKleur%, Tekst$, WrongDelay, GOOD)
COLOR BKleur%, FKleur%
Plijn% = Plijn% - 1
Expand 8, 20, 14, 60
LOCATE 10, 25: PRINT Tekst$
LOCATE 12, 25: PRINT "["; STRING$(30, 32); "]"

DO

DO
a$ = INKEY$
LOOP UNTIL a$ <> ""
PaSS$ = PaSS$ + a$
IF LEN(PaSS$) < 31 THEN LOCATE 12, 26: PRINT STRING$(LEN(PaSS$), 254)
IF LEN(PaSS$) > 30 THEN GOSUB Wrong
LOOP UNTIL INSTR(PaSS$, PassWord$) >= 1
COLOR 7, 0
IF GOOD = 1 THEN CALL GOODPaSSWoRD
EXIT SUB

Wrong:
LOCATE 12, 26: PRINT "WRong PaSSword [RELoading.]   "
FOR i = 1 TO WrongDelay
NEXT i
PaSS$ = ""
LOCATE 12, 25: PRINT "["; STRING$(30, 32); "]"
RETURN




END SUB

DEFSNG A-Z
FUNCTION Path$
DEFINT A-Z
'=================== Function ProgramName$ ======================
'== INPUT: None                                                ==
'== RETURNS: Name of currently executing program               ==
'================================================================
'

DIM regs AS RegType

   regs.ax = &H6200
   CALL INTERRUPT(&H21, regs, regs)
   PSPSegment = regs.bx
   DEF SEG = PSPSegment
   EnvSegment = PEEK(&H2D) * 256 + PEEK(&H2C)


   DEF SEG = EnvSegment
   EOT = False                 'Set end of environment table flag
   Offset = 0

   WHILE NOT EOT
	Byte = PEEK(Offset)       'Get table character
	IF Byte = 0 THEN          'End of environment string?
	 Offset = Offset + 1
	 Byte = PEEK(Offset)
	 IF Byte = 0 THEN        'End of environment?
	    Offset = Offset + 3   'Yes - Skip over nulls & tbl info
	    C% = PEEK(Offset)
	    WHILE C% <> 0                   'Assemble filename string
		 FileN$ = FileN$ + CHR$(C%)    '  from individual
		 Offset = Offset + 1           '  characters
		 C% = PEEK(Offset)
	    WEND
	    EOT = true              'Set flag to exit while/wend loop
	 END IF
	ELSE                        'No-Read more environment string
	Offset = Offset + 1
	END IF
   WEND

FOR i = LEN(FileN$) TO 1 STEP -1
IF RIGHT$(MID$(FileN$, i, 1), 1) = "\" THEN EXIT FOR
a = a + 1
NEXT i
FileN$ = LEFT$(FileN$, LEN(FileN$) - a)
FileN$ = RIGHT$(FileN$, LEN(FileN$) - 2)

Path$ = FileN$
DEF SEG

END FUNCTION

 SUB pause (ticks%)
    DEF SEG = 0
    DO UNTIL TestTick% > ticks%
	IF LEN(INKEY$) THEN EXIT SUB
	LastTick% = GetTick%
	GetTick% = PEEK(&H46C)
	IF LastTick% <> GetTick% THEN
	    TestTick% = TestTick% + 1
	END IF
    LOOP


    DEF SEG
 END SUB

'=================== Function ProgramName$ ======================
'== INPUT: None                                                ==
'== RETURNS: Name of currently executing program               ==
'================================================================
'
FUNCTION ProgramName$

DIM regs AS RegType

   regs.ax = &H6200
   CALL INTERRUPT(&H21, regs, regs)
   PSPSegment = regs.bx
   DEF SEG = PSPSegment
   EnvSegment = PEEK(&H2D) * 256 + PEEK(&H2C)


   DEF SEG = EnvSegment
   EOT = False                 'Set end of environment table flag
   Offset = 0

   WHILE NOT EOT
	Byte = PEEK(Offset)       'Get table character
	IF Byte = 0 THEN          'End of environment string?
	 Offset = Offset + 1
	 Byte = PEEK(Offset)
	 IF Byte = 0 THEN        'End of environment?
	    Offset = Offset + 3   'Yes - Skip over nulls & tbl info
	    C% = PEEK(Offset)
	    WHILE C% <> 0                   'Assemble filename string
		 FileN$ = FileN$ + CHR$(C%)    '  from individual
		 Offset = Offset + 1           '  characters
		 C% = PEEK(Offset)
	    WEND
	    EOT = true              'Set flag to exit while/wend loop
	 END IF
	ELSE                        'No-Read more environment string
	Offset = Offset + 1
	END IF
   WEND

FOR i = LEN(FileN$) TO 1 STEP -1
IF RIGHT$(MID$(FileN$, i, 1), 1) = "\" THEN EXIT FOR
a = a + 1
NEXT i
FileN$ = RIGHT$(FileN$, a)
ProgramName$ = FileN$
   DEF SEG

END FUNCTION

SUB Reboot
OUT &H64, &HFE                  'Reboot area!
END SUB

FUNCTION RenameDiskID (drive$, OldDiskID$, NewDiskID$)

	DIM EFCB AS ExtendedFCBRecord
	DIM InRegsX AS RegTypeX, OutRegsX AS RegTypeX

'EFCB setup

	EFCB.ExtFCB = CHR$(&HFF) 'Set EFCB flag
	EFCB.Attr = CHR$(&H8)    'Vol label attribute
	EFCB.drive = CHR$(ASC(drive$) - 64)

'Rename specific instructions

	L = LEN(OldDiskID$)
	IF L < 11 THEN
		OldDiskID$ = OldDiskID$ + SPACE$(11 - L)
	END IF
	EFCB.Name1 = OldDiskID$

	L = LEN(NewDiskID$)
	IF L < 11 THEN
		NewDiskID$ = NewDiskID$ + SPACE$(11 - L)
	END IF
	EFCB.Name2 = NewDiskID$

'  Call Service 17H to RENAME a volume label

	InRegsX.ax = &H1700        'Call find first FCB
	InRegsX.ds = VARSEG(EFCB)  'Load DS:DX with
	InRegsX.dx = VARPTR(EFCB)  'address of EFCB
	CALL INTERRUPTX(&H21, InRegsX, OutRegsX)

'Set error codes

	IF Lo(OutRegsX.ax) = 0 THEN     'Successful
		RenameDiskID = -1 'True
	ELSE
		RenameDiskID = 0  'False
	END IF

END FUNCTION

SUB RestoreScreen (File$)
COLOR 7, 0
PRINT File$;
PRINT

END SUB

SUB s.TekenKlok

FOR x% = 175 TO 177                              ' Tekenen van de cirkel
  CIRCLE (300, 170), x%                          ' voor de klok.
NEXT x%


FOR U% = 0 TO 360 STEP 6                         ' Zet de tekens voor de
  DRAW "TA=" + VARPTR$(U%) + "BU115"             ' hele uren in de klok.

  IF U MOD 30 = 0 THEN
    DRAW " U10"                                  ' Zet streepje van 10 pixels.
  ELSE
    DRAW "U1"                                    ' Zet streepje van 1 pixel.
  END IF

  PSET (300, 170), 7                             ' Terug naar het middelpunt
NEXT U%


END SUB

SUB s.Wijzers (Seconde$) STATIC

Seconde% = VAL(Seconde$)                         ' Gegevens uit Time$ lezen
uur% = VAL(TIME$)
Minuut% = VAL(MID$(TIME$, 4, 2))


IF Seconde% = 0 THEN                             ' Na verstrijken van een hele
  OudeSecondeWijzer% = 6                         ' minuut worden de
  DRAW "TA=" + VARPTR$(OudeMinuutWijzer%) + "C0 NU90" ' uurwijzer en de
  DRAW "TA=" + VARPTR$(OudeUurWijzer%) + "C0 NU60" ' minuutwijzer gewist
ELSE
  OudeSecondeWijzer% = 360 - (6 * (Seconde% - 1))
END IF


SecondeWijzer% = 360 - (6 * Seconde%)            ' berekening van de richting
MinuutWijzer% = 360 - (6 * Minuut%)              ' van de diverse wijzers.
OudeMinuutWijzer% = MinuutWijzer%
UurWijzer% = 360 - (30 * uur% + Minuut% / 2)
OudeUurWijzer% = UurWijzer%

DRAW "TA=" + VARPTR$(OudeSecondeWijzer%) + "C0 NU110" ' oude secondewijzer
DRAW "TA=" + VARPTR$(SecondeWijzer%) + "C4 NU110" ' wissen, nieuwe plaatsen
DRAW "TA=" + VARPTR$(UurWijzer%) + "C7 NU60"     ' uurwijzer en
DRAW "TA=" + VARPTR$(MinuutWijzer%) + "C7 NU90"  ' minuutwijzer plaatsen

END SUB

SUB SaveScreen (Strin$)
DEFINT A-Z
DIM scherm(3820) AS INTEGER
DEF SEG = &HB800
FOR i = 0 TO 3820
IF CHR$(PEEK(i)) < CHR$(32) THEN GOTO onee
a$ = a$ + CHR$(PEEK(i))
onee:
NEXT i
Strin$ = a$
END SUB

SUB Scroll
FOR i% = 0 TO 2000 STEP 80
REM M% stands for MSB and L%=LSB
M% = FIX(i% / 256): L% = i% - (M% * 256)
OUT &H3D4, 12: OUT &H3D5, M%: OUT &H3D4, 13: OUT &H3D5, L%
WAIT &H3DA, 8 'Wait for vertical retrace
FOR D = 0 TO 1250: NEXT: 'Adjust for different scroll speed
NEXT
FOR i% = 2000 TO 0 STEP -80
M% = FIX(i% / 256): L% = i% - (M% * 256)
OUT &H3D4, 12: OUT &H3D5, M%: OUT &H3D4, 13: OUT &H3D5, L%
WAIT &H3DA, 8: 'waits for vertical retrace
FOR D = 0 TO 1250: NEXT: 'Adjust for different scroll speed
NEXT
END SUB

FUNCTION Selecterror$ (Whitch%)
SELECT CASE Whitch%
CASE 0
Err$ = "Cannot identify error! ERR=0, so no corresponding message exists!"
CASE 1
Err$ = "NEXT without FOR"
CASE 2
Err$ = "Syntax error"
CASE 3
Err$ = "RETURN without GOSUB"
CASE 4
Err$ = "Out of case"
CASE 5
Err$ = "Illegal function call"
CASE 6
Err$ = "Overflow"
CASE 7
Err$ = "Out of memory"
CASE 8
Err$ = "Undefined line number"
CASE 9
Err$ = "Subscript out of range"
CASE 10
Err$ = "Redimensioned array"
CASE 11
Err$ = "Division by zero"
CASE 12
Err$ = "Illegal direct"
CASE 13
Err$ = "Type mismatch"
CASE 14
Err$ = "Out of string space"
CASE 15
Err$ = "String too long"
CASE 16
Err$ = "String formula too complex"
CASE 17
Err$ = "Can't continue"
CASE 18
Err$ = "Undefined user function"
CASE 19
Err$ = "No RESUME"
CASE 20
Err$ = "RESUME without error"
CASE 22
Err$ = "Missing operand"
CASE 23
Err$ = "Line buffer overflow"
CASE 24
Err$ = "Device Timeout"
CASE 25
Err$ = "Device Fault"
CASE 26
Err$ = "FOR without NEXT"
CASE 27
Err$ = "Out of paper"
CASE 29
Err$ = "WHILE without WEND"
CASE 30
Err$ = "WEND without WHILE"
CASE 50
Err$ = "FIELD overflow"
CASE 51
Err$ = "Internal error"
CASE 52
Err$ = "Bad file number"
CASE 53
Err$ = "File not found"
CASE 54
Err$ = "Bad file mode"
CASE 55
Err$ = "File already open"
CASE 57
Err$ = "Device I/O error"
CASE 58
Err$ = "File already exists"
CASE 61
Err$ = "Disk full"
CASE 62
Err$ = "Input past end"
CASE 63
Err$ = "Bad record number"
CASE 64
Err$ = "Bad file name"
CASE 66
Err$ = "Direct statement in file"
CASE 67
Err$ = "Too many files"
CASE 68
Err$ = "Device unavailable"
CASE 69
Err$ = "Communication buffer overflow"
CASE 70
Err$ = "Permission denied"
CASE 71
Err$ = "Disk not ready"
CASE 72
Err$ = "Disk media error"
CASE 73
Err$ = "Advanced feature"
CASE 74
Err$ = "Rename across disks"
CASE 75
Err$ = "Path/file access error"
CASE 76
Err$ = "Path not found"
CASE ELSE
Err$ = "Cannot identify error"
END SELECT

Selecterror$ = Err$
END FUNCTION

FUNCTION SetDiskID (drive$, VolumeName$)

	DIM EFCB AS ExtendedFCBRecord
	DIM InRegsX AS RegTypeX, OutRegsX AS RegTypeX

	CALL GetDTAAddr(Segment, Offset)

'  Call the Find First FCB function
'  using the Volume attribute

	EFCB.ExtFCB = CHR$(&HFF) 'Set EFCB flag
	EFCB.Attr = CHR$(&H8)    'Vol label attribute
	EFCB.drive = CHR$(ASC(drive$) - 64)
	L = LEN(VolumeName$)
	IF L < 11 THEN
		VolumeName$ = VolumeName$ + SPACE$(11 - L)
	END IF
	EFCB.Name1 = VolumeName$
	InRegsX.ax = &H1600        'Call find first FCB
	InRegsX.ds = VARSEG(EFCB)  'Load DS:DX with
	InRegsX.dx = VARPTR(EFCB)  'address of EFCB
	CALL INTERRUPTX(&H21, InRegsX, OutRegsX)

	IF Lo(OutRegsX.ax) = 0 THEN     'Successful
		SetDiskID = -1 'True
	ELSE
		SetDiskID = 0  'False
	END IF
END FUNCTION

 SUB Shadow (UpRow%, LtCol%, LoRow%, RtCol%) STATIC
    DEF SEG = &H40
    mono% = PEEK(&H10)
    IF (mono% AND 48) = 48 THEN
	EXIT SUB            '*** Forget the Shadow if it's monochrome.
    ELSE
	DEF SEG = &HB800
    END IF

 Attr% = SCREEN(LoRow% + 1, RtCol% + 1, -1)  ' Get the attribute.
    Attr% = Attr% AND 15                     ' Calculate forground.
    Attr% = Attr% - 8                        ' Remove bright.
    IF Attr% < 1 THEN Attr% = 8              ' In case color wasn't bright.


    FOR row% = UpRow% + 1 TO LoRow% + 1       '***** right edge locations.
	FOR col% = RtCol% + 1 TO RtCol% + 2   '***** make it 2 chars Wide.
	    Offset% = (row% - 1) * 160 + (col% - 1) * 2 + 1
	    POKE Offset%, Attr%
	NEXT
    NEXT
    row% = LoRow% + 1                        '***** now POKE along the
    FOR col% = LtCol% + 2 TO RtCol% + 2      '***** bottom edge
	Offset% = (row% - 1) * 160 + (col% - 1) * 2 + 1
	POKE Offset%, Attr%
    NEXT
    DEF SEG
 END SUB

SUB ShowGif (File$)
DIM Prefix(4095), Suffix(4095), OutStack(4095), ShiftOut(8)

DIM YBase AS LONG, Powersof2(11) AS LONG, WorkCode AS LONG

FOR a = 0 TO 8: ShiftOut(8 - a) = 2 ^ a: NEXT
FOR a = 0 TO 11: Powersof2(a) = 2 ^ a: NEXT
IF File$ = "" THEN EXIT SUB

FOR a = LEN(File$) TO 1 STEP -1
    SELECT CASE MID$(File$, a, 1)
    CASE "\", ":": EXIT FOR
    CASE ".": Extension = -1: EXIT FOR
    END SELECT
NEXT
IF Extension = 0 THEN File$ = File$ + ".GIF"

OPEN File$ FOR INPUT AS #1: CLOSE #1
OPEN File$ FOR BINARY AS #1

File$ = "      ": GET #1, , File$
IF LEFT$(File$, 3) <> "GIF" THEN PRINT "Not a GIF file.": END

GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((a AND 7) + 1): NoPalette = (a AND 128) = 0
GOSUB GetByte: Background = a

GOSUB GetByte

IF NoPalette = 0 THEN P$ = SPACE$(NumColors * 3): GET #1, , P$

DO
DO
    DO
	  IF EOF(1) THEN EXIT DO
	  GOSUB GetByte
    LOOP WHILE a = 0

    SELECT CASE a
    CASE 44
	  EXIT DO
    CASE 59
	  GOTO AllDone
    CASE IS <> 33
	  PRINT "Unknown GIF extension type.": END
    END SELECT
    GOSUB GetByte
    DO: GOSUB GetByte: File$ = SPACE$(a): GET #1, , File$: LOOP UNTIL a = 0
LOOP

GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength

GOSUB GetByte
IF (a AND 128) THEN
    NoPalette = 0
    NumColors = 2 ^ ((a AND 7) + 1)
    P$ = SPACE$(NumColors * 3): GET #1, , P$
END IF

Interlaced = (a AND 64) > 0: PassNumber = 0: passStep = 8

GOSUB GetByte

ClearCode = 2 ^ a
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = a + 1: CodeSize = StartCodeSize

StartMaxCode = 2 ^ (a + 1) - 1: MaxCode = StartMaxCode

BitsIn = 0: BlockSize = 0: BlockPointer = 1

x = XStart: y = YStart: YBase = y * 320&

IF FirstTime = 0 THEN
    SCREEN 13: DEF SEG = &HA000
END IF

IF NoPalette = 0 THEN
    OUT &H3C8, 0
    FOR a = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(P$, a, 1)) \ 4: NEXT
END IF

IF FirstTime = 0 THEN
    LINE (0, 0)-(319, 199), Background, BF
    FirstTime = -1
END IF

DO
    GOSUB GetCode
    IF Code <> EOSCode THEN
	  IF Code = ClearCode THEN
		NextCode = FirstCode
		CodeSize = StartCodeSize
		MaxCode = StartMaxCode
		GOSUB GetCode
		CurCode = Code: LastCode = Code: LastPixel = Code
		IF x < 320 AND y < 200 THEN POKE x + YBase, LastPixel
		x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
	  ELSE
		CurCode = Code: StackPointer = 0
		IF Code >= NextCode THEN
		    IF Code > NextCode THEN GOTO AllDone
		    CurCode = LastCode
		    OutStack(StackPointer) = LastPixel
		    StackPointer = StackPointer + 1
		END IF

		DO WHILE CurCode >= FirstCode
		    OutStack(StackPointer) = Suffix(CurCode)
		    StackPointer = StackPointer + 1
		    CurCode = Prefix(CurCode)
		LOOP

		LastPixel = CurCode
		IF x < 320 AND y < 200 THEN POKE x + YBase, LastPixel
		x = x + 1: IF x = XEnd THEN GOSUB NextScanLine

		FOR a = StackPointer - 1 TO 0 STEP -1
		    IF x < 320 AND y < 200 THEN POKE x + YBase, OutStack(a)
		    x = x + 1: IF x = XEnd THEN GOSUB NextScanLine
		NEXT

		IF NextCode < 4096 THEN
		    Prefix(NextCode) = LastCode
		    Suffix(NextCode) = LastPixel
		    NextCode = NextCode + 1
		    IF (NextCode > MaxCode) AND (CodeSize < 12) THEN
			  CodeSize = CodeSize + 1
			  MaxCode = MaxCode * 2 + 1
		    END IF
		END IF
		LastCode = Code
	  END IF
    END IF
LOOP UNTIL Code = EOSCode

LOOP
AllDone:
BEEP
SLEEP
SCREEN 0
WIDTH 80
EXIT SUB

GetByte:
File$ = " ": GET #1, , File$: a = ASC(File$): RETURN

NextScanLine:
    IF Interlaced THEN
	  y = y + passStep
	  IF y >= YEnd THEN
		PassNumber = PassNumber + 1
		SELECT CASE PassNumber
		CASE 1: y = 4: passStep = 8
		CASE 2: y = 2: passStep = 4
		CASE 3: y = 1: passStep = 2
		END SELECT
	  END IF
    ELSE
	  y = y + 1
    END IF
    x = XStart: YBase = y * 320&
RETURN

GetCode:
    WorkCode = LastChar \ ShiftOut(BitsIn)
    DO WHILE CodeSize > BitsIn
	  IF BlockPointer > BlockSize THEN
     
		GOSUB GetByte: BlockSize = a
		File$ = SPACE$(BlockSize): GET #1, , File$
		BlockPointer = 1
	  END IF
     
	  LastChar = ASC(MID$(File$, BlockPointer, 1))
	  BlockPointer = BlockPointer + 1
     
	  WorkCode = WorkCode OR LastChar * Powersof2(BitsIn)
	  BitsIn = BitsIn + 8
    LOOP
 
    BitsIn = BitsIn - CodeSize
 
    Code = WorkCode AND MaxCode
RETURN


END SUB

SUB ShowKlok
CLS
SCREEN 9
COLOR 7, 1
LOCATE 24, 25
PRINT "Druk op een toets om te stoppen";

CALL s.TekenKlok                                 ' Teken de klok op het scherm
DO
  Seconde$ = RIGHT$(TIME$, 2)
  CALL s.Wijzers(Seconde$)                       ' roep subprocedure aan
  DO
    LOCATE 2, 34
    PRINT TIME$                                  ' druk de tijd digitaal af
    In$ = INKEY$
  LOOP WHILE Seconde$ = RIGHT$(TIME$, 2) AND In$ = ""

LOOP WHILE In$ = ""
SCREEN 0


END SUB

SUB Sterren
SCREEN 13
OUT &H3C8, 0
FOR n = 1 TO 63
  OUT &H3C9, n
  OUT &H3C9, n
  OUT &H3C9, n
NEXT n

DIM Stars(1 TO 200) AS StarType
DIM Stars1(1 TO 200) AS StarType
DIM Stars2(1 TO 200) AS StarType
DIM Stars3(1 TO 200) AS StarType
DIM OldStars(1 TO 200) AS StarType

FOR n = 1 TO 200

  Stars1(n).Angle = RND * 360
  Stars1(n).Speed = RND + 1
  Stars1(n).Brite = RND * 10
  Stars1(n).Dis = RND * 200

  Stars2(n).Angle = (n * 3.6) MOD 360
  Stars2(n).Speed = 2
  Stars2(n).Brite = 1
  Stars2(n).Dis = (n * 25) MOD 200

  IF n MOD 3 = 0 THEN
    Stars3(n).Angle = (n * 3.6) MOD 360
    Stars3(n).Speed = 3
    Stars3(n).Brite = 1
    Stars3(n).Dis = n
  ELSEIF n MOD 3 = 1 THEN
    Stars3(n).Angle = ((n + 33) * 3.6) MOD 360
    Stars3(n).Speed = 3
    Stars3(n).Brite = 1
    Stars3(n).Dis = n
  ELSEIF n MOD 3 = 2 THEN
    Stars3(n).Angle = ((n + 66) * 3.6) MOD 360
    Stars3(n).Speed = 3
    Stars3(n).Brite = 1
    Stars3(n).Dis = n
  END IF

NEXT n

DIM s(360)
DIM C(360) AS INTEGER

FOR n = 0 TO 360
  s(n) = SIN(n / 57.32) * 100 * 1.2
  C(n) = COS(n / 57.32) * 100
NEXT n

SCREEN 13
CLS
REDIM Temp(5000)

FOR n = 1 TO 200
  Stars(n).Angle = Stars1(n).Angle
  Stars(n).Speed = Stars1(n).Speed
  Stars(n).Brite = Stars1(n).Brite
  Stars(n).Dis = Stars1(n).Dis
NEXT n

DO
  D = (D + 1) MOD 360
  FOR n = 1 TO 200
    Stars(n).RealX = 160 + (C(Stars(n).Angle) - s(Stars(n).Angle) * Stars(n).Dis) \ 100
    Stars(n).RealY = 100 + (s(Stars(n).Angle) + C(Stars(n).Angle) * Stars(n).Dis) \ 100
    IF Stars(n).RealY < 11 THEN Stars(n).RealY = 200
  NEXT n
  FOR n = 1 TO 200
    PSET (OldStars(n).RealX, OldStars(n).RealY), 1 '0
    PSET (Stars(n).RealX, Stars(n).RealY), Stars(n).Brite + Stars(n).Dis \ 3
    OldStars(n).RealX = Stars(n).RealX
    OldStars(n).RealY = Stars(n).RealY
  NEXT n
  IF rotation <> 0 THEN
    FOR n = 1 TO 200
	Stars(n).Dis = (Stars(n).Dis + Stars(n).Speed) MOD 200
	Stars(n).Angle = (Stars(n).Angle + rotation) MOD 360
    NEXT n
  ELSE
    FOR n = 1 TO 200
	Stars(n).Dis = (Stars(n).Dis + Stars(n).Speed) MOD 200
    NEXT n
  END IF
  Sp = Sp + 1

  OUT &H3C8, 70
  OUT &H3C9, (1 * Sp) MOD 40 + 20
  OUT &H3C9, (2 * Sp) MOD 40 + 20
  OUT &H3C9, (3 * Sp) MOD 40 + 20

  IF Sp \ 8 = 122 THEN
    rotation = 1
  END IF

  IF Sp \ 8 = 256 THEN
    rotation = 358
  END IF

  IF Sp \ 8 = 512 THEN
    rotation = 0
    FOR n = 1 TO 200
	Stars(n).Angle = Stars2(n).Angle
	Stars(n).Speed = Stars2(n).Speed
	Stars(n).Brite = Stars2(n).Brite
	Stars(n).Dis = Stars2(n).Dis
    NEXT n
  END IF

  IF Sp \ 8 = 762 THEN
    rotation = 1
  END IF

  IF Sp \ 8 = 1024 THEN
    rotation = 358
  END IF

  IF Sp \ 8 = 1256 THEN
    rotation = 0

    FOR n = 1 TO 200
	Stars(n).Angle = Stars3(n).Angle
	Stars(n).Speed = Stars3(n).Speed
	Stars(n).Brite = Stars3(n).Brite
	Stars(n).Dis = Stars3(n).Dis
    NEXT n
  END IF

  IF Sp \ 8 = 1512 THEN
    rotation = 1
  END IF

  IF Sp \ 8 = 1974 THEN
    rotation = 358
  END IF

LOOP UNTIL LEN(INKEY$)

REDIM Stars1(0) AS StarType
REDIM Stars2(0) AS StarType
REDIM Stars3(0) AS StarType

REDIM Stars(0) AS StarType
REDIM OldStars(0) AS StarType
SCREEN 0
WIDTH 80, 25
EXIT SUB
END SUB

SUB ViewFile (FileName$)
CONST False = 0: CONST true = NOT False
uparrow = 18432: downarrow = 20480: pgup = 18688: pgdn = 20736
home = 18176: endkey = 20224: escape = 27
DIM a$(1 TO 9000)       'modify this for file size



CALL fileread(FileName$, linecount%, a$())
ON ERROR GOTO 0
CLS
lineptr% = 1
DO
 COLOR 0, 3
 VIEW PRINT
 LOCATE 1, 1
 PRINT "Line:"; LEFT$(STR$(lineptr%) + SPACE$(7), 8);
 PRINT "File: "; LEFT$(FileName$ + SPACE$(19), 19);
 PRINT "Quit: ESC"; SPACE$(3);
 PRINT "Move "; CHR$(24); " "; CHR$(25); " PGUP PGDN HOME END   ";
 COLOR 7, 1
 VIEW PRINT 2 TO 25
 FOR i% = 0 TO 23
  LOCATE i% + 2, 1
  PRINT LEFT$(a$(i% + lineptr%) + SPACE$(80), 80);
 NEXT i%
 SELECT CASE keycode%
 CASE uparrow
  IF lineptr% > 1 THEN
   lineptr% = lineptr% - 1
  END IF
 CASE downarrow
  IF lineptr% < linecount% THEN
   lineptr% = lineptr% + 1
  END IF
 CASE pgup
  IF lineptr% > 1 THEN
   lineptr% = lineptr - 24
   IF lineptr% < 1 THEN
    lineptr% = 1
   END IF
  END IF
 CASE pgdn
  IF lineptr% < linecount% - 24 THEN
   lineptr% = lineptr% + 24
   IF lineptr% > linecount% THEN
    lineptr% = linecount%
   END IF
  END IF
 CASE home
  IF lineptr% > 1 THEN
   lineptr% = 1
  END IF
 CASE endkey
  IF lineptr% < linecount% - 24 THEN
   lineptr% = linecount% - 24
  END IF
 CASE escape
  quitflag% = true
 CASE ELSE
  updateflag% = False
 END SELECT
LOOP UNTIL quitflag%
CLOSE
VIEW PRINT
EXIT SUB

END SUB

DEFSNG A-Z
SUB wacht
FOR tijd = 1 TO 1250: NEXT tijd

END SUB