'WAV,GIF,PCX,FLI,DBF,DOSEXEC,COM,ASCII,BMP,MID?? DEFINT A-Z DECLARE FUNCTION ReadFileStructure% () DECLARE FUNCTION RightJust$ (Value$, FieldWidth%) DECLARE FUNCTION ZeroJust$ (Number AS INTEGER) DECLARE FUNCTION ReadDBFHdr% () DECLARE SUB DSPDBFInfo () DECLARE SUB DSPFileStructure () DECLARE SUB DBFPause () DECLARE SUB ShowDBase (FileName$) DECLARE SUB PrintDBFRecord (FV$(), RecNum%) DECLARE SUB PrintReport () DECLARE SUB ReadDBFRecord (FV$()) DECLARE SUB ShowBox (Comm$) DECLARE SUB PlayWav (WaveFile$) DECLARE SUB ValidWavHeader (File$, LenHeader%, DataLen&, NChannels%, NSamplesPerSec&, NAvgBytesPerSec&, OK%) DECLARE SUB WriteToDSP (V%) DECLARE SUB PlayBack (Buffer$, Size%, Freq&, BytesPerSec&, Chans%, Num%) DECLARE SUB WDelay (TDelay!) DECLARE FUNCTION GetBlasterAddr% () DECLARE FUNCTION SBreset% () DECLARE FUNCTION UInt (A$) DECLARE SUB PCXInfo (FileName$) DECLARE SUB FLIPlay (FileName$, ErrCode%) DECLARE SUB GIFLoad (FileName$) DECLARE FUNCTION Int86QB$ (Intnr%, Flag%, AX%, BX%, CX%, DX%, DI%, SI%, BP%, DS%, ES%) DECLARE FUNCTION Int2Str$ (SWord%) DECLARE FUNCTION LoadAndPlayMIDI% (FileName$) DECLARE SUB LoadMIDI (FileName$) DECLARE SUB PCXLoad (File$) DECLARE FUNCTION PlayMIDI% () DECLARE SUB PokeString (SegJE%, OffJE%, Main$) DECLARE SUB ShowBMP (FileName$) DECLARE SUB StopMIDI () DECLARE FUNCTION TimeMIDI! () DECLARE SUB ziCenter (Row%, Text$) DECLARE SUB ziExhaust () DECLARE SUB ziLoadFont (Font$) DECLARE SUB ziLocateMCursor (Xcoord, YCoord) DECLARE SUB ziPublishHere (Row%, Col%, Printstring$, Size%, italic%) DECLARE SUB ziPublish (Printstring$, Size, italic) DECLARE SUB ziReadField (Min, Max, Permitted$) DECLARE SUB ziSetMCursorVis (Status) DECLARE SUB zsAlignGCursor () DECLARE SUB zsAlignTCursor () DECLARE SUB zsLocateGCursor (Xcoord, YCoord) DECLARE SUB zsSetScrnMode (Mode, HiRows, HiCols) DECLARE SUB zzAlphaSort (Table$()) DECLARE SUB zzBasicInt (IntType) DECLARE SUB zzChangeDir (Directory$) DECLARE SUB zzChangeDrive (Drive$) DECLARE SUB zzCritOff () DECLARE SUB zzCritOn () DECLARE SUB zzFileSelectBox (Pattern$) DECLARE SUB zzInPath (Field$) DECLARE SUB zzSearchD (Pattern$) DECLARE SUB zzSearchF (Pattern$) DECLARE SUB zzValidate (Directory$) COMMON SHARED BlasterAddr%, DMA%, Repeats% TYPE REGISTERS AX AS INTEGER BX AS INTEGER CX AS INTEGER DX AS INTEGER DS AS INTEGER SI AS INTEGER ES AS INTEGER DI AS INTEGER FL AS INTEGER END TYPE TYPE FLIHeaderType Size AS LONG ID AS INTEGER Frames AS INTEGER XRes AS INTEGER YRes AS INTEGER ColorBits AS INTEGER Flags AS INTEGER Speed AS INTEGER Reserved AS STRING * 110 END TYPE TYPE FLIFrameChunkType Size AS LONG ID AS INTEGER Chunks AS INTEGER Reserved AS STRING * 8 END TYPE TYPE FLIDataChunkType Size AS LONG ID AS INTEGER END TYPE DIM SHARED FLIHeader AS FLIHeaderType DIM SHARED FLIFrameChunk AS FLIFrameChunkType DIM SHARED FLIDataChunk AS FLIDataChunkType TYPE TH Man AS STRING * 1 Ver AS STRING * 1 Enc AS STRING * 1 Bit AS STRING * 1 Xls AS INTEGER Yls AS INTEGER Xms AS INTEGER Yms AS INTEGER Hre AS INTEGER Vre AS INTEGER Col AS STRING * 48 Res AS STRING * 1 Pla AS STRING * 1 Byt AS INTEGER Pal AS INTEGER Fil AS STRING * 58 END TYPE DIM SHARED PCXHeader AS TH DIM SHARED PCXDat AS STRING * 1 DIM SHARED PCXA AS LONG DIM SHARED PCXB AS LONG DIM SHARED PCXC AS LONG DIM SHARED PCXX AS LONG DIM SHARED PCXY AS LONG DIM SHARED BitCount TYPE PCXHeader Ident AS STRING * 1 Ver AS STRING * 1 Encoding AS STRING * 1 BPP AS STRING * 1 XMin AS STRING * 2 YMin AS STRING * 2 XMax AS STRING * 2 YMax AS STRING * 2 XRes AS STRING * 2 YRes AS STRING * 2 END TYPE TYPE PCXHeader2 Res1 AS STRING * 1 NPlanes AS STRING * 1 BytesPerLine AS STRING * 2 Palinfo AS STRING * 2 HorzScreen AS STRING * 2 VertScreen AS STRING * 2 Res2 AS STRING * 54 END TYPE DIM SHARED PCXFileHeader AS PCXHeader DIM SHARED PCXFileHeader2 AS PCXHeader2 TYPE DBFHeaderInfoType VersionNumber AS INTEGER LastUpdate AS STRING * 8 NumberRecords AS LONG HeaderLength AS INTEGER RecordLength AS INTEGER NumberFields AS INTEGER FileSize AS LONG END TYPE DIM SHARED DBFHdr AS DBFHeaderInfoType TYPE DBFFieldInfoType FdName AS STRING * 11 FdType AS STRING * 1 FdLength AS INTEGER FdDec AS INTEGER END TYPE DIM SHARED Flds(DBFHdr.NumberFields) AS DBFFieldInfoType CONST Pi! = 3.14159 CONST Ex! = 2.71828 CONST DegToRad! = .0174533 CONST RadToDeg! = 57.2958 CONST False = 0 CONST True = NOT False DIM SHARED Regs AS REGISTERS DIM SHARED Bad, Module$ DIM SHARED Mouse, MCursorVis, MXLoc, MYLoc DIM SHARED DClick DIM SHARED ScrnMode, BG, FG, TCursor DIM SHARED XMax, YMax, GXloc, GYloc, XYratio! DIM SHARED Rows, Cols, Row, Col DIM SHARED Allowed$, Field$ DIM SHARED FoundButton DIM SHARED Font(255, 7) DIM SHARED Response, HResponse, LResponse DIM SHARED SortCount REDIM SHARED Directories$(200) REDIM SHARED Filenames$(800) DIM SHARED Directories, Filenames DIM SHARED Dev, OldDev, Exists DIM SHARED Middle, MaxTop, MaxLeft DIM SHARED FileHeader AS STRING * 32 DIM SHARED GifHeader AS STRING * 6 DIM SHARED FileName AS STRING * 150 DIM SHARED FileType$, FT$ DIM SHARED WhereLeftOff$ DIM SHARED LenOF AS LONG DIM SHARED GIFPrefix(4095), GIFSuffix(4095), GIFOutStack(4095), GIFShiftOut%(8) DIM SHARED GIFYBase AS LONG, GIFPowersOf2(11) AS LONG, GIFWorkCode AS LONG DIM SHARED MIDI.Loaded AS INTEGER DIM SHARED MIDI.PlayTime AS SINGLE DIM SHARED MIDI.Interrupt AS INTEGER DIM SHARED PCXColourMap$ DIM SHARED PCXPal$ PCXColourMap$ = SPACE$(48) PCXPal$ = SPACE$(768) MIDI.Loaded = 0 MIDI.PlayTime = 0 MIDI.Interrupt = &H81 Middle = 318 MaxTop = 180 MaxLeft = 30 DIM SHARED IRET AS STRING * 3 IRET = CHR$(&HB0) + CHR$(&H0) + CHR$(&HCF) DIM SHARED CritSeg, CritPtr, CritCount Regs.AX = &H3524 CALL zzBasicInt(&H21) CritSeg = Regs.ES CritPtr = Regs.BX RANDOMIZE TIMER ON ERROR GOTO RESUMENEXT RESUMENEXT: IF ERR = 255 THEN CLS BEEP PRINT "Cannot find module "; Module$ SLEEP SCREEN 0 CLS COLOR 7, 0 CLS END END IF IF ERR THEN Bad = ERR RESUME NEXT END IF Mouse = 0 Regs.AX = 0 CALL zzBasicInt(&H33) IF Regs.AX THEN Mouse = 1 CALL ziSetMCursorVis(0) END IF CALL ziLoadFont("Ascii8x8") Allowed$ = "aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ\.:~!@#$%^&*()_+-=[]{}" + CHR$(31) FOR LV = 128 TO 255 Allowed$ = Allowed$ + CHR$(fgh) NEXT LV 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» 'º THIS IS THE MAIN PROGRAM - ADD CODE YOU WANT HERE º 'º ³ º 'º \³/ º 'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ DO NewFile = 0 DO SCREEN 0 WIDTH 80, 25 FileGot = 0 Dev = 0 OldDev = 0 GOSUB OpenFile CLS LOOP WHILE Bad <> 0 DO IF FT$ = "WAV" THEN GOSUB DispWav ELSEIF FT$ = "GIF" THEN GOSUB DispGif ELSEIF FT$ = "PCX" THEN GOSUB ViewPCX ELSEIF FT$ = "MID" THEN GOSUB PlayMid ELSEIF FT$ = "FLI" THEN GOSUB ShowFLI ELSEIF FT$ = "BMP" THEN GOSUB ViewBMP ELSEIF FT$ = "DBF" THEN GOSUB ViewDBF ELSEIF FT$ = "COM" OR FT$ = "DOSEXEC" THEN GOSUB RunDOSExecutable ELSEIF FT$ = "ASCII" THEN GOSUB ShowText ELSE SCREEN 0 WIDTH 80, 25 LOCATE 4, 1: PRINT "File Size:"; COLOR 10: PRINT LenOF; COLOR 9: PRINT "Bytes" COLOR 9 LOCATE 5, 1: PRINT "This is "; IF UCASE$(LEFT$(FileType$, 1)) <> "A" AND UCASE$(LEFT$(FileType$, 1)) <> "E" AND UCASE$(LEFT$(FileType$, 1)) <> "I" AND UCASE$(LEFT$(FileType$, 1)) <> "O" AND UCASE$(LEFT$(FileType$, 1)) <> "U" THEN PRINT "a "; ELSE PRINT "an "; COLOR 10 PRINT FileType$ GOSUB Proceed NewFile = 1 END IF LOOP UNTIL NewFile = 1 LOOP END 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» 'º SUBROUTINES - DO NOT ALTER ANY OF THESE!!!!!!!!!!!!!!!!!! º 'º ³ º 'º \³/ º 'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ OpenFile: CLOSE #1 Bad = 0 IF FileName = "?" + SPACE$(149) THEN SCREEN 0 CLS COLOR 7, 0 CLS SYSTEM END IF IF FileGot = 0 THEN GOSUB FileBox FileGot = 1 GOTO OpenFile END IF OPEN FileName FOR INPUT AS #1 IF Bad <> 0 THEN COLOR 11 Cant$ = "! Cannot find " + RTRIM$(FileName) + " !" LOCATE 5, 41 - LEN(Cant$) / 2 PRINT Cant$; COLOR 2 LOCATE 5, POS(1) - LEN(RTRIM$(FileName)) - 2 PRINT RTRIM$(FileName) GOSUB Proceed RETURN END IF CLOSE #1 OPEN FileName FOR RANDOM AS #1 LEN = 256 GET #1, 1, FileHeader GET #1, 1, FLIHeader LenOF = LOF(1) COLOR 9 FileType$ = "Unrecognised or Ascii file": FT$ = "ASCII" IF LEFT$(FileHeader, 1) = CHR$(233) THEN FileType$ = "Command File (COM)": FT$ = "COM" IF LEFT$(FileHeader, 1) = CHR$(188) THEN FileType$ = "Command File (COM)": FT$ = "COM" IF LEFT$(FileHeader, 2) = "BM" THEN FileType$ = "BitMap File (BMP)": FT$ = "BMP" IF LEFT$(FileHeader, 2) = CHR$(10) + CHR$(5) THEN FileType$ = "PaintBrush File (PCX)": FT$ = "PCX" IF LEFT$(FileHeader, 2) = CHR$(10) + CHR$(3) THEN FileType$ = "PaintBrush File (PCX)": FT$ = "PCX" IF LEFT$(FileHeader, 2) = CHR$(71) + CHR$(73) THEN FileType$ = "Graphic Image File (GIF)": FT$ = "GIF" IF LEFT$(FileHeader, 2) = CHR$(215) + CHR$(205) THEN FileType$ = "Windows MetaFile (WMF)": FT$ = "WMF" IF LEFT$(FileHeader, 2) = CHR$(49) + CHR$(190) THEN FileType$ = "Windows Write File (WRI)": FT$ = "WRI" IF LEFT$(FileHeader, 4) = "RIFF" THEN IF MID$(FileHeader, 9, 4) = "WAVE" THEN FileType$ = "Wave File (WAV)": FT$ = "WAV" IF MID$(FileHeader, 9, 4) = "sfbk" THEN FileType$ = "Creative WaveTable Voice File (SBK)": FT$ = "SBK" END IF IF LEFT$(FileHeader, 4) = "MThd" THEN FileType$ = "MIDI Sequencer File (MID)": FT$ = "MID" IF LEFT$(FileHeader, 2) = CHR$(67) + CHR$(84) THEN FileType$ = "Compressed MIDI Sequencer File (CMF)": FT$ = "CMF" IF LEFT$(FileHeader, 2) = CHR$(67) + CHR$(77) THEN FileType$ = "Creative Pro-Organ File (ORG)": FT$ = "ORG" IF LEFT$(FileHeader, 4) = "SBI" + CHR$(&H1A) THEN FileType$ = "Sound Blaster Instrument File (SBI)": FT$ = "SBI" IF LEFT$(FileHeader, 4) = "IBK" + CHR$(&H1A) THEN FileType$ = "Sound Blaster Instrument Bank File (IBK)": FT$ = "IBK" IF LEFT$(FileHeader, 4) = "CTMF" THEN FileType$ = "Creative Music File (CMF)": FT$ = "CMF" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(75) THEN FileType$ = "PK Utilities Compressed File (ZIP)": FT$ = "ZIP" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(77) THEN FileType$ = "Windows Program Manager Group File (GRP)": FT$ = "GRP" IF LEFT$(FileHeader, 2) = CHR$(63) + CHR$(95) THEN FileType$ = "Windows Help Index (GID)": FT$ = "GID" IF LEFT$(FileHeader, 2) = CHR$(0) + CHR$(1) THEN FileType$ = "True Type Font (TTF)": FT$ = "TTF" IF LEFT$(FileHeader, 2) = CHR$(76) + CHR$(0) THEN FileType$ = "Windows 95 Link File (LNK)": FT$ = "LNK" IF LEFT$(FileHeader, 2) = CHR$(208) + CHR$(207) THEN FileType$ = "Microsoft Word File (DOC)": FT$ = "DOC" IF LEFT$(FileHeader, 2) = CHR$(176) + CHR$(77) THEN FileType$ = "Windows 95 Password File (PWL)": FT$ = "PWL" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(195) THEN FileType$ = "Windows Clipboard Save File (CLP)": FT$ = "CLP" IF LEFT$(FileHeader, 2) = CHR$(77) + CHR$(90) THEN IF MID$(FileHeader, 3, 3) = CHR$(144) + CHR$(0) + CHR$(3) THEN FileType$ = "Windows Executable File (EXE, DLL, SCR etc..)": FT$ = "WINEXEC" IF MID$(FileHeader, 4, 1) = CHR$(1) THEN FileType$ = "DOS Executable File (EXE, DLL, OVL etc..)": FT$ = "DOSEXEC" IF MID$(FileHeader, 3, 2) = CHR$(0) + CHR$(0) THEN FileType$ = "Windows Virtual Device Driver (VXD)": FT$ = "VXD" END IF IF LEFT$(FileHeader, 5) = CHR$(0) + CHR$(0) + CHR$(0) + CHR$(72) + CHR$(0) THEN FileType$ = "Cubasis Music File (ALL)": FT$ = "ALL" IF LEFT$(FileHeader, 20) = "SuperCalc ver. 1.10" THEN FileType$ = "SuperCalc SpreadSheet (CAL)": FT$ = "CAL" IF LEFT$(FileHeader, 2) = CHR$(0) + CHR$(120) THEN FileType$ = "Windows Program Information File (PIF)": FT$ = "PIF" IF FLIHeader.ID = &HAF11 THEN FileType$ = "AutoDesk Animator Flic File (FLI)": FT$ = "FLI" IF FLIHeader.ID = &HAF12 THEN FileType$ = "AutoDesk Animator Flic File (FLI)": FT$ = "FLI" IF LEFT$(FileHeader, 19) = "Creative Voice File" THEN FileType$ = "Creative Voice File (VOC)": FT$ = "VOC" IF (ASC(LEFT$(FileHeader, 1)) AND (7)) = 3 THEN FileType$ = "dBase DataBase File (DBF)": FT$ = "DBF" '/======================================================================== '/ Search for other file types ' 'LOCATE 13, 1: PRINT FileHeader, ASC(MID$(FileHeader, 1)), ASC(MID$(FileHeader, 2)), ASC(MID$(FileHeader, 3)), ASC(MID$(FileHeader, 4)), ASC(MID$(FileHeader, 5)) '/========================================================================= CLOSE #1 RETURN Proceed: COLOR 15 LOCATE 23, 30 PRINT "Press a key to proceed"; GOSUB Sleeper LOCATE 24, 30 PRINT SPACE$(23); RETURN Sleeper: GOSUB SleeperSound X$ = "X" WHILE LEN(X$) > 0: X$ = INKEY$: WEND WHILE LEN(X$) = 0: X$ = INKEY$: WEND RETURN SleeperSound: FOR I = 300 TO 380 STEP 8 SOUND I, 1 NEXT RETURN FileBox: FG = 15: BG = 0 CALL zsSetScrnMode(9, 0, 1) FG = 0 FG = 15 X$ = "*.*" CALL zzFileSelectBox(X$) SCREEN 0 WIDTH 80, 25 CLS FileName = X$ RETURN NoFile: Exists = 0 RESUME NEXT DispGif: SCREEN 13 GIFLoad FileName NewFile = 1 RETURN DispWav: SCREEN 9 CLS PlayWav FileName LOCATE 25, 1: PRINT "Press a key to continue..."; SLEEP NewFile = 1 RETURN ViewPCX: SCREEN 9 CLS PCXInfo FileName LOCATE 25, 1: PRINT "Press a key to continue..."; SLEEP SCREEN 13 CLS PCXLoad FileName LOCATE 25, 1: PRINT "Press a key to continue..."; SLEEP NewFile = 1 RETURN PlayMid: SCREEN 9 'IF LoadAndPlayMIDI%(FileName) = 0 THEN ' LOCATE 1, 1 ' PRINT "ERROR!! Failed to load the sample MIDI file." ' PRINT "Press a key to continue..." ' A$ = INPUT$(1) 'ELSE ' DO WHILE INKEY$ = "" ' 'Get the number of seconds the MIDI file has been playing. ' PlayTime! = INT(TimeMIDI!) ' IF PlayTime! > 999 THEN ' StopMIDI ' A% = PlayMIDI ' END IF ' FOR I% = 1 TO 6: WAIT &H3DA, 8, 8: WAIT &H3DA, 8: NEXT I% ' LOCATE 7, 22: PRINT STRING$(11, 32); ' COLOR 15 ' LOCATE 7, 22 ' PRINT LTRIM$(STR$(PlayTime!)) + " seconds."; ' LOOP ' StopMIDI 'END IF NewFile = 1 RETURN ShowFLI: SCREEN 13 FLIPlay FileName, ErrCode% IF ErrCode% > 0 THEN LOCATE 1, 1: PRINT "Error Occured! : ErrCode ="; ErrCode%; END IF LOCATE 25, 1: PRINT "Press a key to Continue..."; SLEEP NewFile = 1 RETURN ViewBMP: SCREEN 13 ShowBMP FileName LOCATE 25, 1: PRINT "Press a key to Continue..."; SLEEP NewFile = 1 RETURN RunDOSExecutable: SCREEN 0 COLOR 7, 0 CLS WIDTH 80, 25 Ext$ = RIGHT$(RTRIM$(FileName$), 3) IF Ext$ = "COM" THEN SHELL FileName$ ELSEIF Ext$ = "EXE" THEN SHELL FileName$ ELSE LOCATE 1, 1: PRINT "Can not run this file!"; END IF LOCATE 25, 1: PRINT "Press a key to Continue..."; SLEEP NewFile = 1 RETURN ShowText: SCREEN 0 COLOR 7, 0 CLS WIDTH 80, 25 Ext$ = RIGHT$(RTRIM$(FileName$), 3) OkayToView = 0 IF Ext$ = "TXT" THEN OkayToView = 1 IF Ext$ = "DOC" THEN OkayToView = 1 IF Ext$ = "1ST" THEN OkayToView = 1 IF Ext$ = "ME" THEN OkayToView = 1 IF Ext$ = "LST" THEN OkayToView = 1 IF OkayToView = 0 THEN LOCATE 1, 1: PRINT "This is not a recognised Text file extension, do you wish to view it? (Y/N)"; Ans$ = "" WHILE Ans$ <> "Y" AND Ans$ <> "N" Ans$ = UCASE$(INKEY$) WEND IF Ans$ = "N" THEN NewFile = 1: RETURN END IF CLS LOCATE 1, 1: PRINT "Reading File... " ShowBox FileName RUN TooLong: LOCATE 1, 1 PRINT "ERROR!: File is too long, Out of memory" LOCATE 25, 1: PRINT "Press a key to Continue..."; SLEEP RUN ViewDBF: SCREEN 0 COLOR 7, 0 CLS WIDTH 80, 25 ShowDBase FileName LOCATE 25, 1: PRINT "Press a key to Continue..."; SLEEP NewFile = 1 RETURN SUB DBFPause PRINT PRINT "Press any key to continue" WHILE INKEY$ = "": WEND END SUB SUB DSPDBFInfo PRINT USING "dBASE Version : #"; DBFHdr.VersionNumber PRINT "Database in use : "; FileName$ PRINT USING "Number of data records: ########"; DBFHdr.NumberRecords PRINT "Date of last update : "; DBFHdr.LastUpdate PRINT USING "Header length : ####"; DBFHdr.HeaderLength PRINT USING "Record length : ####"; DBFHdr.RecordLength PRINT USING "Number of fields : ###"; DBFHdr.NumberFields PRINT USING "File size : ########"; DBFHdr.FileSize END SUB SUB DSPFileStructure FieldTitleS$ = "Field Field Name Type Width Dec" FieldString1$ = " ### \ \ " FieldString2$ = "\ \ ### ##" PRINT : PRINT FieldTitleS$ FOR I = 1 TO DBFHdr.NumberFields PRINT USING FieldString1$; I; Flds(I).FdName; SELECT CASE Flds(I).FdType CASE "C": ty$ = "Character" CASE "L": ty$ = "Logical" CASE "N": ty$ = "Number" CASE "F": ty$ = "Floating Pt" CASE "D": ty$ = "Date" CASE "M": ty$ = "Memo" CASE ELSE: ty$ = "Unknown" END SELECT PRINT USING FieldString2$; ty$; Flds(I).FdLength; Flds(I).FdDec NEXT I PRINT " ** Total **"; TAB(33); PRINT USING "####"; DBFHdr.RecordLength END SUB DEFSNG A-Z SUB FLIPlay (FileName$, ErrCode%) DIM Byte AS STRING * 1 ErrCode% = 0 FileNum% = FREEFILE OPEN FileName$ FOR BINARY AS FileNum% '--- Get the File's Header --- GET #FileNum%, , FLIHeader IF FLIHeader.ID <> &HAF11 AND FLIHeader.ID <> &HAF12 THEN ErrCode% = 1 '<-- Not a FLI or FLC file (error) CLOSE FileNum% EXIT SUB END IF IF FLIHeader.XRes <> 320 OR FLIHeader.YRes <> 200 THEN ErrCode% = 2 '<-- Not a 320x200x256 Color Flic (error) LOCATE 1, 1: PRINT "Xres:"; FLIHeader.XRes; LOCATE 2, 1: PRINT "Yres:"; FLIHeader.YRes; LOCATE 3, 1: PRINT "ColorBits:"; FLIHeader.ColorBits; CLOSE FileNum% EXIT SUB END IF '--- Loop Thru Each Frame --- DEF SEG = &HA000 FOR Frame% = 1 TO FLIHeader.Frames '*** FRAMES: Displays Frame Number in Upper-Left Corner *** FramePos& = LOC(FileNum%) '<-- Needed? -- GET #FileNum%, , FLIFrameChunk IF FLIFrameChunk.ID = &HF1FA THEN FOR Chunk% = 1 TO FLIFrameChunk.Chunks DataPos& = LOC(FileNum%) '<-- Needed? -- << v1.1 >> GET #FileNum%, , FLIDataChunk SELECT CASE FLIDataChunk.ID CASE 4, 11 '--*-- COLOR256/COLOR64: Change Palette --*-- Index% = 0 GET #FileNum%, , PacketNum% FOR A% = 1 TO PacketNum% GET #FileNum%, , Byte: SkipByte% = ASC(Byte) GET #FileNum%, , Byte: ChangeByte% = ASC(Byte) Index% = Index% + SkipByte% IF ChangeByte% = 0 THEN ChangeByte% = 256 FOR B% = 1 TO ChangeByte% GET #FileNum%, , Byte: RedByte% = ASC(Byte) GET #FileNum%, , Byte: GreenByte% = ASC(Byte) GET #FileNum%, , Byte: BlueByte% = ASC(Byte) IF FLIDataChunk.ID = 4 THEN '-- Change Palette (0-255) -- OUT &H3C8, Index% OUT &H3C9, RedByte% \ 4 OUT &H3C9, GreenByte% \ 4 OUT &H3C9, BlueByte% \ 4 ELSE '-- Change Palette (0-63) -- OUT &H3C8, Index% OUT &H3C9, RedByte% OUT &H3C9, GreenByte% OUT &H3C9, BlueByte% END IF Index% = Index% + 1 NEXT B% NEXT A% CASE 12 '--*-- LC: Byte Aligned Delta Compression --*-- GET #FileNum%, , StartLine% GET #FileNum%, , Byte: NumLines% = ASC(Byte) LinePos& = StartLine% * 320& GET #FileNum%, , Byte: StartByte% = ASC(Byte) FOR Y% = 1 TO NumLines% GET #FileNum%, , Byte: PacketByte% = ASC(Byte) X% = StartByte% FOR A% = 1 TO PacketByte% GET #FileNum%, , Byte: SkipByte% = ASC(Byte) GET #FileNum%, , Byte: SizeByte% = ASC(Byte) X% = X% + SkipByte% IF SizeByte% > 127 THEN SizeByte% = -(SizeByte% OR &HFF00) GET #FileNum%, , Byte: PixelByte% = ASC(Byte) FOR B% = 1 TO SizeByte% 'DEF SEG = &HA000 POKE LinePos& + X%, PixelByte% 'DEF SEG X% = X% + 1 NEXT B% ELSE FOR B% = 1 TO SizeByte% GET #FileNum%, , Byte: PixelByte% = ASC(Byte) POKE LinePos& + X%, PixelByte% X% = X% + 1 NEXT B% END IF NEXT A% LinePos& = LinePos& + 320 NEXT Y% GET #FileNum%, , Byte '<-- Needed? -- CASE 7 '--*-- SS2: Word Aligned Delta Compression (FLC Only)--*-- LinePos& = 0 GET #FileNum%, , NumLines% FOR Y% = 1 TO NumLines% LastPixel% = -1 '<-- For ODD Width Flics (not used) DO GET #FileNum%, , Word% WordType% = (Word% AND &HC000) SELECT CASE WordType% CASE 0: PacketCount% = Word% CASE &H8000: LastPixel% = (Word% AND &HFF) CASE &HC000: LinePos& = LinePos& + (Word% * -320&) END SELECT LOOP UNTIL WordType% = 0 X% = 0 FOR A% = 1 TO PacketCount% GET #FileNum%, , Byte: SkipByte% = ASC(Byte) GET #FileNum%, , Byte: SizeByte% = ASC(Byte) X% = X% + SkipByte% IF SizeByte% > 127 THEN SizeByte% = -(SizeByte% OR &HFF00) GET #FileNum%, , PixelWord% PixelByte1% = PixelWord% AND &HFF PixelByte2% = PixelWord% \ 255 'Don't Work for Neg # GET #FileNum%, , Byte: PixelByte1% = ASC(Byte) GET #FileNum%, , Byte: PixelByte2% = ASC(Byte) FOR B% = 1 TO SizeByte% POKE LinePos& + X%, PixelByte1% POKE LinePos& + X% + 1, PixelByte2% X% = X% + 2 NEXT B% ELSE FOR B% = 1 TO SizeByte% GET #FileNum%, , PixelWord% GET #FileNum%, , Byte: PixelByte1% = ASC(Byte) GET #FileNum%, , Byte: PixelByte2% = ASC(Byte) POKE LinePos& + X%, (PixelWord% AND &HFF) POKE LinePos& + X% + 1, (PixelWord% \ 255) POKE LinePos& + X%, PixelByte1% POKE LinePos& + X% + 1, PixelByte2% X% = X% + 2 NEXT B% END IF NEXT A% '-- Following is for ODD Width Flics (not used) -- IF LastPixel% > -1 THEN POKE LinePos& + FLIHeader.XRes - 1, LastPixel% END IF LinePos& = LinePos& + 320 NEXT Y% CASE 13 '--*-- BLACK: Black-Out Screen --*-- CLS CASE 15 '--*-- BRUN: Byte Run Length Compression --*-- LinePos& = 0 FOR Y% = 1 TO 200 GET #FileNum%, , Byte X% = 0 DO GET #FileNum%, , Byte: SizeByte% = ASC(Byte) IF SizeByte% > 127 THEN SizeByte% = -(SizeByte% OR &HFF00) FOR B% = 1 TO SizeByte% GET #FileNum%, , Byte: PixelByte% = ASC(Byte) POKE LinePos& + X%, PixelByte% X% = X% + 1 NEXT B% 'ELSEIF SizeByte% = 0 THEN '*** Test *** ELSE GET #FileNum%, , Byte: PixelByte% = ASC(Byte) FOR B% = 1 TO SizeByte% POKE LinePos& + X%, PixelByte% X% = X% + 1 NEXT B% END IF LOOP UNTIL X% >= 320 LinePos& = LinePos& + 320 NEXT Y% GET #FileNum%, , Byte '<-- Needed? -- CASE 16 '--*-- COPY: Bitmap of Entire Image --*-- FOR P& = 0 TO 64000 GET #FileNum%, , Byte: PixelByte% = ASC(Byte) POKE P&, PixelByte% NEXT P& CASE ELSE '--*-- Unknown Data Chunk, so Skip Over --*-- SEEK FileNum%, DataPos& + FLIDataChunk.Size + 1 '<< v1.1 >> END SELECT NEXT Chunk% ELSE '--- Unknown Frame Chunk, so Skip Over --- END IF SEEK FileNum%, FramePos& + FLIFrameChunk.Size + 1 '<-- Needed? -- '*** PAUSE: Uncomment Following Lines for a Pause Between Frames! *** WDelay FLIHeader.Speed * 1 / 70 ''NOTE: The REAL Pause should be FLIHeader.Speed * 1/70 of a second, '' but because the frame updates are so slow, I didn't include '' the pause here. (FLI files ONLY!) NEXT Frame% DEF SEG CLOSE FileNum% END SUB DEFINT A-Z FUNCTION GetBlasterAddr% 'Get Blaster Address and DMA channel from Environment Variable Tmp% = 0 'No Environment Variable Set...default Blast$ = UCASE$(ENVIRON$("BLASTER")) IF LEN(Blast$) THEN Tmp% = INSTR(Blast$, "A") Tmp1$ = MID$(Blast$, Tmp% + 1, 3) Tmp% = VAL("&H" + Tmp1$) IF Tmp% = 203 THEN Tmp% = -1 'If there is no value assigned IF Tmp% > 0 THEN Tmp2% = INSTR(Blast$, "D") DMA% = VAL(MID$(Blast$, Tmp2% + 1)) 'dma% is a global variable IF DMA% < 0 OR DMA% > 7 THEN Tmp% = -2 END IF END IF GetBlasterAddr% = Tmp% END FUNCTION DEFSNG A-Z SUB GIFLoad (GIFFile$) DEFINT A-Z CLS FOR GIFVar% = 0 TO 7: GIFShiftOut%(8 - GIFVar%) = 2 ^ GIFVar%: NEXT GIFVar% FOR GIFVar% = 0 TO 11: GIFPowersOf2(GIFVar%) = 2 ^ GIFVar%: NEXT GIFVar% RESET OPEN GIFFile$ FOR BINARY AS #1 GET #1, , GifHeader IF GifHeader <> "GIF87a" THEN PRINT "Not a GIF87a file.": SLEEP: EXIT SUB GET #1, , GIFTotalX: GET #1, , GIFTotalY: GOSUB GetByte GIFNumColors = 2 ^ ((GIFVar% AND 7) + 1): GIFNoPalette = (GIFVar% AND 128) = 0 GOSUB GetByte: GIFBackground = GIFVar% GOSUB GetByte: IF GIFVar% <> 0 THEN PRINT "Bad screen descriptor.": SLEEP: EXIT SUB IF GIFNoPalette = 0 THEN GIFP$ = SPACE$(GIFNumColors * 3): GET #1, , GIFP$ DO GOSUB GetByte IF GIFVar% = 44 THEN EXIT DO ELSEIF GIFVar% <> 33 THEN PRINT "Unknown extension type.": SLEEP: EXIT SUB END IF GOSUB GetByte DO: GOSUB GetByte: GIFFile$ = SPACE$(GIFVar%): GET #1, , GIFFile$: LOOP UNTIL GIFVar% = 0 LOOP GET #1, , GIFXStart: GET #1, , GIFYStart: GET #1, , GIFXLength: GET #1, , GIFYLength GIFXEnd = GIFXStart + GIFXLength: GIFYEnd = GIFYStart + GIFYLength: GOSUB GetByte IF GIFVar% AND 128 THEN PRINT "Can't handle local colormaps.": SLEEP: EXIT SUB GIFInterlaced = GIFVar% AND 64: GIFPassNumber = 0: GIFPassStep = 8 GOSUB GetByte GIFClearCode = 2 ^ GIFVar% GIFEOSCode = GIFClearCode + 1 GIFFirstCode = GIFClearCode + 2: GIFNextCode = GIFFirstCode GIFStartCodeSize = GIFVar% + 1: GIFCodeSize = GIFStartCodeSize GIFStartMaxCode = 2 ^ (GIFVar% + 1) - 1: GIFMaxCode = GIFStartMaxCode GIFBitsIn = 0: GIFBlockSize = 0: GIFBlockPointer = 1 GIFX% = GIFXStart: GIFY% = GIFYStart: GIFYBase = GIFY% * 320& SCREEN 13 DEF SEG = &HA000 IF GIFNoPalette = 0 THEN OUT &H3C7, 0: OUT &H3C8, 0 FOR GIFVar% = 1 TO GIFNumColors * 3: OUT &H3C9, ASC(MID$(GIFP$, GIFVar%, 1)) \ 4: NEXT GIFVar% END IF LINE (0, 0)-(319, 199), GIFBackground, BF DO GOSUB GetCode IF GIFCode <> GIFEOSCode THEN IF GIFCode = GIFClearCode THEN GIFNextCode = GIFFirstCode GIFCodeSize = GIFStartCodeSize GIFMaxCode = GIFStartMaxCode GOSUB GetCode GIFCurCode = GIFCode: GIFLastCode = GIFCode: GIFLastPixel = GIFCode IF GIFX% < 320 THEN POKE GIFX% + GIFYBase, GIFLastPixel GIFX% = GIFX% + 1: IF GIFX% = GIFXEnd THEN GOSUB NextScanLine ELSE GIFCurCode = GIFCode: GIFStackPointer = 0 IF GIFCode > GIFNextCode THEN EXIT DO IF GIFCode = GIFNextCode THEN GIFCurCode = GIFLastCode GIFOutStack(GIFStackPointer) = GIFLastPixel GIFStackPointer = GIFStackPointer + 1 END IF DO WHILE GIFCurCode >= GIFFirstCode GIFOutStack(GIFStackPointer) = GIFSuffix(GIFCurCode) GIFStackPointer = GIFStackPointer + 1 GIFCurCode = GIFPrefix(GIFCurCode) LOOP GIFLastPixel = GIFCurCode IF GIFX% < 320 THEN POKE GIFX% + GIFYBase, GIFLastPixel GIFX% = GIFX% + 1: IF GIFX% = GIFXEnd THEN GOSUB NextScanLine FOR GIFVar% = GIFStackPointer - 1 TO 0 STEP -1 IF GIFX% < 320 THEN POKE GIFX% + GIFYBase, GIFOutStack(GIFVar%) GIFX% = GIFX% + 1: IF GIFX% = GIFXEnd THEN GOSUB NextScanLine NEXT GIFVar% IF GIFNextCode < 4096 THEN GIFPrefix(GIFNextCode) = GIFLastCode GIFSuffix(GIFNextCode) = GIFLastPixel GIFNextCode = GIFNextCode + 1 IF GIFNextCode > GIFMaxCode AND GIFCodeSize < 12 THEN GIFCodeSize = GIFCodeSize + 1 GIFMaxCode = GIFMaxCode * 2 + 1 END IF END IF GIFLastCode = GIFCode END IF END IF LOOP UNTIL GIFDoneFlag OR GIFCode = GIFEOSCode BEEP A$ = INPUT$(1) CLOSE #1 EXIT SUB GetByte: GIFFile$ = " " GET #1, , GIFFile$ GIFVar% = ASC(GIFFile$) RETURN NextScanLine: IF GIFInterlaced THEN GIFY% = GIFY% + GIFPassStep IF GIFY% >= GIFYEnd THEN GIFPassNumber = GIFPassNumber + 1 SELECT CASE GIFPassNumber CASE 1: GIFY% = 4: GIFPassStep = 8 CASE 2: GIFY% = 2: GIFPassStep = 4 CASE 3: GIFY% = 1: GIFPassStep = 2 END SELECT END IF ELSE GIFY% = GIFY% + 1 END IF GIFX% = GIFXStart: GIFYBase = GIFY% * 320&: GIFDoneFlag = GIFY% > 199 RETURN GetCode: IF GIFBitsIn = 0 THEN GOSUB ReadBufferedByte: GIFLastChar = GIFVar%: GIFBitsIn = 8 GIFWorkCode = GIFLastChar \ GIFShiftOut%(GIFBitsIn) DO WHILE GIFCodeSize > GIFBitsIn GOSUB ReadBufferedByte: GIFLastChar = GIFVar% GIFWorkCode = GIFWorkCode OR GIFLastChar * GIFPowersOf2(GIFBitsIn) GIFBitsIn = GIFBitsIn + 8 LOOP GIFBitsIn = GIFBitsIn - GIFCodeSize GIFCode = GIFWorkCode AND GIFMaxCode RETURN ReadBufferedByte: IF GIFBlockPointer > GIFBlockSize THEN GOSUB GetByte: GIFBlockSize = GIFVar% GIFFile$ = SPACE$(GIFBlockSize): GET #1, , GIFFile$ GIFBlockPointer = 1 END IF GIFVar% = ASC(MID$(GIFFile$, GIFBlockPointer, 1)): GIFBlockPointer = GIFBlockPointer + 1 RETURN END SUB FUNCTION Int2Str$ (SWord%) DEF SEG = VARSEG(SWord%) Ptr% = VARPTR(SWord%) Int2Str$ = CHR$(PEEK(Ptr%)) + CHR$(PEEK(Ptr% + 1)) DEF SEG END FUNCTION FUNCTION Int86QB$ (Intnr%, Flag%, AX%, BX%, CX%, DX%, DI%, SI%, BP%, DS%, ES%) Flag$ = LEFT$(Int2Str$(Flag%), 1): AX$ = Int2Str$(AX%): BX$ = Int2Str$(BX%): CX$ = Int2Str$(CX%): DX$ = Int2Str$(DX%): DI$ = Int2Str$(DI%): SI$ = Int2Str$(SI%): BP$ = Int2Str$(BP%): DS$ = Int2Str$(DS%): ES$ = Int2Str$(ES%): DIM DataS%(11) DataSeg% = VARSEG(DataS%(0)): FlagOff% = VARPTR(DataS%(0)) DataSeg$ = Int2Str$(DataSeg%): FlagOff$ = Int2Str$(FlagOff%) AXOff$ = Int2Str$(FlagOff% + 2): BXOff$ = Int2Str$(FlagOff% + 4) CXOff$ = Int2Str$(FlagOff% + 6): DXOff$ = Int2Str$(FlagOff% + 8) DIOff$ = Int2Str$(FlagOff% + 10): SIOff$ = Int2Str$(FlagOff% + 12) BPOff$ = Int2Str$(FlagOff% + 14): DSOff$ = Int2Str$(FlagOff% + 16) ESOff$ = Int2Str$(FlagOff% + 18): IntnrOff$ = Int2Str$(FlagOff% + 20) Asm$ = "" Asm$ = Asm$ + CHR$(&H9C) 'pushf Asm$ = Asm$ + CHR$(&H50) 'push ax Asm$ = Asm$ + CHR$(&H53) 'push bx Asm$ = Asm$ + CHR$(&H51) 'push cx Asm$ = Asm$ + CHR$(&H52) 'push dx Asm$ = Asm$ + CHR$(&H57) 'push di Asm$ = Asm$ + CHR$(&H56) 'push si Asm$ = Asm$ + CHR$(&H55) 'push bp Asm$ = Asm$ + CHR$(&H1E) 'push ds Asm$ = Asm$ + CHR$(&H6) 'push es Asm$ = Asm$ + CHR$(&HB4) + Flag$ 'mov ax,flag$ Asm$ = Asm$ + CHR$(&H9E) 'sahf stores ah into flags IF DS% <> 0 THEN 'safety Asm$ = Asm$ + CHR$(&HB8) + DS$ 'mov ax,ds$ Asm$ = Asm$ + CHR$(&H8E) + CHR$(&HD8) 'mov ds,ax END IF IF ES% <> 0 THEN 'safety Asm$ = Asm$ + CHR$(&HB8) + ES$ 'mov ax,es$ Asm$ = Asm$ + CHR$(&H8E) + CHR$(&HC0) 'mov es,ax END IF Asm$ = Asm$ + CHR$(&HB8) + AX$ 'mov ax,ax$ Asm$ = Asm$ + CHR$(&HBB) + BX$ 'mov bx,bx$ Asm$ = Asm$ + CHR$(&HB9) + CX$ 'mov cx,cx$ Asm$ = Asm$ + CHR$(&HBA) + DX$ 'mov dx,dx$ Asm$ = Asm$ + CHR$(&HBF) + DI$ 'mov di,di$ Asm$ = Asm$ + CHR$(&HBE) + SI$ 'mov si,si$ Asm$ = Asm$ + CHR$(&HBD) + BP$ 'mov bp,bp$ Asm$ = Asm$ + CHR$(&HCD) + CHR$(Intnr%) 'interrupt nr Asm$ = Asm$ + CHR$(&H1E) 'push ds Asm$ = Asm$ + CHR$(&HB8) + DataSeg$ 'mov ax,DATASseg$ Asm$ = Asm$ + CHR$(&H8E) + CHR$(&HD8) 'mov ds,ax Asm$ = Asm$ + CHR$(&H8F) + CHR$(&H6) + DSOff$ 'pop dsoff$ Asm$ = Asm$ + CHR$(&H8C) + CHR$(&H6) + ESOff$ 'mov esoff$,ES Asm$ = Asm$ + CHR$(&H9F) 'lahf Asm$ = Asm$ + CHR$(&H88) + CHR$(&H26) + FlagOff$ 'mov flagoff$,ah Asm$ = Asm$ + CHR$(&H89) + CHR$(&H2E) + BPOff$ 'mov bpoff$,bp Asm$ = Asm$ + CHR$(&H89) + CHR$(&H36) + SIOff$ 'mov sioff$,si Asm$ = Asm$ + CHR$(&H89) + CHR$(&H3E) + DIOff$ 'mov dioff$,di Asm$ = Asm$ + CHR$(&H89) + CHR$(&H16) + DXOff$ 'mov dxoff$,dx Asm$ = Asm$ + CHR$(&H89) + CHR$(&HE) + CXOff$ 'mov cxoff$,cx Asm$ = Asm$ + CHR$(&H89) + CHR$(&H1E) + BXOff$ 'mov bxoff$,bx Asm$ = Asm$ + CHR$(&HA3) + AXOff$ 'mov axoff$,ax Asm$ = Asm$ + CHR$(&H7) 'pop es Asm$ = Asm$ + CHR$(&H1F) 'pop ds Asm$ = Asm$ + CHR$(&H5D) 'pop bp Asm$ = Asm$ + CHR$(&H5E) 'pop si Asm$ = Asm$ + CHR$(&H5F) 'pop di Asm$ = Asm$ + CHR$(&H5A) 'pop dx Asm$ = Asm$ + CHR$(&H59) 'pop cx Asm$ = Asm$ + CHR$(&H5B) 'pop bx Asm$ = Asm$ + CHR$(&H58) 'pop ax Asm$ = Asm$ + CHR$(&H9D) 'popf Asm$ = Asm$ + CHR$(&HCB) 'retf DEF SEG = VARSEG(Asm$) OffCode% = SADD(Asm$): CALL Absolute(OffCode%): DEF SEG UI$ = HEX$(Intnr%) FOR I% = 0 TO 9 HX$ = HEX$(DataS%(I%)) HX$ = STRING$(4 - LEN(HX$), "0") + HX$ UI$ = UI$ + "," + HX$ NEXT Int86QB$ = UI$ END FUNCTION FUNCTION LoadAndPlayMIDI% (FileName$) IF INSTR(FileName$, ".") = 0 THEN FileName$ = FileName$ + ".MID" IF RIGHT$(FileName$, 1) <> CHR$(0) THEN FileName$ = FileName$ + CHR$(0) IF MIDI.Interrupt = 0 THEN MIDI.Interrupt = &H81 A$ = Int86QB$(MIDI.Interrupt, 0, SADD(FileName$), &H500, 0, VARSEG(FileName$), 0, 0, 0, 0, 0) MIDI.Loaded = -1 A$ = Int86QB$(MIDI.Interrupt, 0, 0, &H501, 0, 0, 0, 0, 0, 0, 0) AX$ = MID$(A$, 9, 4) AX% = VAL(AX$) IF NOT AX% THEN LoadAndPlayMIDI% = -1 MIDI.PlayTime = TIMER END IF END FUNCTION SUB LoadMIDI (FileName$) IF INSTR(FileName$, ".") = 0 THEN FileName$ = FileName$ + ".MID" IF RIGHT$(FileName$, 1) <> CHR$(0) THEN FileName$ = FileName$ + CHR$(0) IF MIDI.Interrupt = 0 THEN MIDI.Interrupt = &H81 A$ = Int86QB$(MIDI.Interrupt, 0, SADD(FileName$), &H500, 0, VARSEG(FileName$), 0, 0, 0, 0, 0) MIDI.Loaded = -1 END SUB SUB PCXInfo (FileName$) OPEN FileName$ FOR BINARY ACCESS READ AS #1 SEEK #1, 1 GET #1, , PCXFileHeader IF ASC(PCXFileHeader.Ver) = 5 THEN GET #1, , PCXColourMap$ GET #1, , PCXFileHeader2 CLS PRINT "File: "; UCASE$(FileName$) PRINT "Identifier: "; IF PCXFileHeader.Ident = CHR$(10) THEN PRINT "PCX" ELSE PRINT "Unknown ="; ASC(PCXFileHeader.Ident) END IF PRINT "Version:"; IF PCXFileHeader.Ver = CHR$(2) THEN PRINT " 2 - Old PCX - No Palette" ELSEIF PCXFileHeader.Ver = CHR$(3) THEN PRINT " 3 - No Palette" ELSEIF PCXFileHeader.Ver = CHR$(4) THEN PRINT " 4 - MS Windows - No Palette" ELSEIF PCXFileHeader.Ver = CHR$(5) THEN PRINT " 5 - With Palette" ELSE PRINT PCXFileHeader.Ver; " - Unknown" END IF PRINT "Encoding Type:"; IF PCXFileHeader.Encoding = CHR$(1) THEN PRINT " 1 - PCX" ELSE PRINT PCXFileHeader.Encoding; " - Unknown" END IF PRINT "Bits Per Pixel:"; ASC(PCXFileHeader.BPP) PRINT "Image Window: ("; LTRIM$(STR$(UInt(PCXFileHeader.XMin))); ","; PRINT LTRIM$(STR$(UInt(PCXFileHeader.YMin))); ") to ("; PRINT LTRIM$(STR$(UInt(PCXFileHeader.XMax))); ","; PRINT LTRIM$(STR$(UInt(PCXFileHeader.YMax))); ")" PRINT "Horizontal Resolution:"; UInt(PCXFileHeader.XRes) PRINT "Vertical Resolution:"; UInt(PCXFileHeader.YRes) PRINT "Reserved:"; ASC(PCXFileHeader2.Res1) PRINT "Number of Planes:"; ASC(PCXFileHeader2.NPlanes) PRINT "Bytes Per Line:"; UInt(PCXFileHeader2.BytesPerLine) IF (UInt(PCXFileHeader2.BytesPerLine) MOD 2) = 0 THEN PRINT "Bytes per line per plane even - Good." ELSE PRINT "Bytes per line odd - Huh?" END IF PRINT "Palette:"; IF UInt(PCXFileHeader2.Palinfo) = 0 THEN PRINT " 0 - RLE Compressed?" ELSEIF UInt(PCXFileHeader2.Palinfo) = 1 THEN PRINT " 1 - Index B&W or Colour" ELSEIF UInt(PCXFileHeader2.Palinfo) = 2 THEN PRINT " 2 - Ordered shades of grey" ELSE PRINT UInt(PCXFileHeader2.Palinfo); "- Unknown" END IF PRINT "Recommended horizontal screen size:"; UInt(PCXFileHeader2.HorzScreen) PRINT "Recommended vertical screen size:"; UInt(PCXFileHeader2.VertScreen) Q = SEEK(1) SEEK #1, Q + UInt(PCXFileHeader2.BytesPerLine) * (UInt(PCXFileHeader.YMax) - UInt(PCXFileHeader.YMin) + 1) EOFM$ = " " GET #1, , EOFM$ IF EOFM$ = CHR$(12) THEN PRINT "End of PCX Bitmap Data found." ELSE PRINT LTRIM$(STR$(ASC(EOFM$))); " found. Expecting End of PCX Data marker (0C)." END IF IF EOF(1) THEN PRINT "End of File." IF (PCXFileHeader.Ver = CHR$(5)) AND (ASC(PCXFileHeader.BPP) > 4) THEN PRINT "Oh oh, we are missing our palette." END IF ELSE BytesLeft = LOF(1) - SEEK(1) + 1 PRINT LTRIM$(STR$(BytesLeft)); " bytes after PCX data." IF BytesLeft = 3 * (2 ^ (ASC(PCXFileHeader.BPP))) THEN PRINT "Which matches the size of our palette." ELSE PRINT "Which mis-matches our palette size." PRINT "Palette size:"; 3 * (2 ^ (ASC(PCXFileHeader.BPP))) PRINT "End of Bitmap Data:"; SEEK(1) PRINT "Size of PCX file:"; LOF(1) END IF END IF END SUB SUB PCXLoad (File$) OPEN File$ FOR BINARY AS #1 LOCATE 1, 1: PRINT "Loading Palette..."; GET #1, LOF(1) - 768, PCXDat FOR LPS = 0 TO 255 GET #1, , PCXDat PCXA = INT(ASC(PCXDat) / 4) GET #1, , PCXDat PCXB = INT(ASC(PCXDat) / 4) GET #1, , PCXDat PCXC = INT(ASC(PCXDat) / 4) Slot = LPS GOSUB ChangeColour NEXT LPS LOCATE 1, 1: PRINT " "; GET #1, 1, PCXHeader PCXC = 1 PCXY = 1: PCXX = 1 WHILE PCXC <= 64000 GET #1, , PCXDat IF ASC(PCXDat) > 192 AND ASC(PCXDat) <= 255 THEN LPS = ASC(PCXDat) - 192 GET #1, , PCXDat Value = ASC(PCXDat) WHILE LPS > 0 PSET (PCXX, PCXY), Value IF PCXX = 320 THEN PCXX = 1: PCXY = PCXY + 1 ELSE PCXX = PCXX + 1 PCXC = PCXC + 1 LPS = LPS - 1 WEND ELSE Value = ASC(PCXDat) PSET (PCXX, PCXY), Value IF PCXX = 320 THEN PCXX = 1: PCXY = PCXY + 1 ELSE PCXX = PCXX + 1 PCXC = PCXC + 1 END IF WEND CLOSE #1 EXIT SUB ChangeColour: R& = PCXA G& = PCXB B& = PCXC G& = G& * 256 B& = B& * 65536 RGB& = R& + G& + B& PALETTE Slot, RGB& RETURN END SUB SUB PlayBack (Buffer$, Size%, Freq&, BytesPerSec&, Chans%, Num%) Size% = Size% - 1 Segment& = VARSEG(Buffer$) Offset& = SADD(Buffer$) IF Segment& < 0 THEN Segment& = Segment& + 65536 IF Offset& < 0 THEN Offset& = Offset& + 65536 BaseAddr& = Segment& * 16 + Offset& Look1% = VARPTR(BaseAddr&) Look2% = VARPTR(Size%) SELECT CASE DMA% CASE 0 DMAPage% = &H87 DMAAddr% = 0 DMALen% = 1 CASE 1 DMAPage% = &H83 DMAAddr% = 2 DMALen% = 3 CASE 2 DMAPage% = &H81 DMAAddr% = 4 DMALen% = 5 CASE 3 DMAPage% = &H82 DMAAddr% = 6 DMALen% = 7 CASE 4 DMAPage% = &H8F DMAAddr% = &HC0 DMALen% = &HC2 CASE 5 DMAPage% = &H8B DMAAddr% = &HC4 DMALen% = &HC6 CASE 6 DMAPage% = &H89 DMAAddr% = &HC8 DMALen% = &HCA CASE 7 DMAPage% = &H8A DMAAddr% = &HCC DMALen% = &HCE END SELECT SELECT CASE DMA% CASE 0 TO 3 DMAMask% = &HA DMAMode% = &HB DMAClear% = &HC DMAStatus% = &H8 CASE 4 TO 7 DMAMask% = &HD4 DMAMode% = &HD6 DMAClear% = &HD8 DMAStatus% = &HD0 END SELECT SELECT CASE DMA% CASE 0, 4 DMATerminal% = 1 CASE 1, 5 DMATerminal% = 2 CASE 2, 6 DMATerminal% = 4 CASE 3, 7 DMATerminal% = 8 END SELECT OUT DMAMask%, DMA% + 4 'mask the dma channel OUT DMAClear%, &H0 '(clear the internal DMA flip/flop) OUT DMAMode%, 72 + DMA% ' 72=010010XX where XX=dmachannel% OUT DMAAddr%, PEEK(Look1%) 'bits 0-7 of the 20bit address OUT DMAAddr%, PEEK(Look1% + 1) 'bits 8-15 of the 20bit address OUT DMAPage%, PEEK(Look1% + 2) 'bits 16-19 of the 20 bit address OUT DMALen%, PEEK(Look2%) 'bits 0-7 of size% OUT DMALen%, PEEK(Look2% + 1) 'bits 8-15 of size% OUT DMAMask%, DMA% 'enable channel IF Num% = 1 THEN 'only need to Write out time constant once TimeConst% = 256 - 1000000 / (Freq& * Chans%) CALL WriteToDSP(&H40) CALL WriteToDSP(TimeConst%) 'Reset Mixer DSPmixeraddress = Blasteraddr% + &H4 OUT BlasterAddr% + &H4, &H0 OUT BlasterAddr% + &H4 + 1, 0 'Set Volume to Maximum...255 OUT BlasterAddr% + &H4, &H22 OUT BlasterAddr% + &H4 + 1, 255 IF Chans% = 2 THEN 'Set mixer to Stereo Output OUT BlasterAddr% + &H4, &HE OUT BlasterAddr% + &H4 + 1, 34 '34=2^5+2^1 END IF END IF IF BytesPerSec& > 22000 THEN CALL WriteToDSP(&H48) 'Set Block Size ELSE CALL WriteToDSP(&H14) 'DMA Mode 8-bit DAC END IF CALL WriteToDSP(PEEK(Look2%)) 'Lo byte of address CALL WriteToDSP(PEEK(Look2% + 1)) 'High byte of address IF BytesPerSec& > 22000 THEN CALL WriteToDSP(&H91) 'High Speed DMA mode 8-bit Dummy% = INP(DMAStatus%) 'Read status byte once to make sure DMA is going. WAIT DMAStatus%, DMATerminal% 'Loop until terminal count bit set in DMA status register 'DMA Transfer is Now Complete 'Acknowledge the DSP interrupt by reading the DATA AVAILABLE port once Dummy% = INP(BlasterAddr% + &HE) 'DSP Available address END SUB FUNCTION PlayMIDI% IF MIDI.Loaded = 0 THEN EXIT FUNCTION IF MIDI.Interrupt = 0 THEN MIDI.Interrupt = &H81 A$ = Int86QB$(MIDI.Interrupt, 0, 0, &H501, 0, 0, 0, 0, 0, 0, 0) AX$ = MID$(A$, 9, 4) AX% = VAL(AX$) IF NOT AX% THEN PlayMIDI% = -1 MIDI.PlayTime = TIMER END IF END FUNCTION DEFSNG A-Z SUB PlayWav (WaveFile$) Repeats% = 1 BlasterAddr% = GetBlasterAddr% SELECT CASE BlasterAddr% CASE -2 PRINT "Bad DMA Channel specified!" EXIT SUB CASE -1 PRINT "No Port Base Address Given!" EXIT SUB CASE 0 PRINT "No BLASTER Environment Variable Set!" EXIT SUB CASE ELSE END SELECT IF NOT SBreset% THEN PRINT "SoundBlaster Card Would Not Reset!" EXIT SUB END IF SP% = INSTR(Spec$, " ") IF SP% THEN WaveFile$ = LEFT$(Spec$, SP% - 1) Repeats% = VAL(RIGHT$(Spec$, LEN(Spec$) - SP%)) IF Repeats% = 0 THEN Repeats% = 1 ELSE IF LEN(Spec$) THEN WaveFile$ = Spec$ Repeats% = 1 END IF END IF IF LEN(WaveFile$) = 0 THEN END IF CALL ValidWavHeader(WaveFile$, LenHeader%, WavLen&, Channels%, Sampling&, Bytes&, OK%) IF NOT OK% THEN PRINT "Bad Wave File Format" EXIT SUB END IF MaxBuffer% = 7053 CALL WriteToDSP(&HD1) 'Speaker ON FOR Repeat% = 1 TO Repeats% 'This can loop to play the file ii% times] FileNum% = FREEFILE OPEN WaveFile$ FOR BINARY AS FileNum% Num% = 0 SEEK FileNum%, LenHeader% + 1 Remaining& = WavLen& DO Num% = Num% + 1 IF Remaining& > MaxBuffer% THEN BufferLen% = MaxBuffer% ELSE BufferLen% = Remaining& END IF Remaining& = Remaining& - BufferLen% Buffer$ = SPACE$(BufferLen%) GET FileNum%, , Buffer$ CALL PlayBack(Buffer$, BufferLen%, Sampling&, Bytes&, Channels%, Num%) LOOP WHILE Remaining& > 0 OUT &H20, &H20 'Reset Normal Interrupt Service CLOSE FileNum% NEXT Repeat% CALL WriteToDSP(&HD3) 'Speaker OFF END SUB DEFINT A-Z SUB PokeString (SegJE%, OffJE%, Main$) DEF SEG = SegJE% FOR I% = 0 TO LEN(Main$) - 1 POKE OffJE% + I%, ASC(MID$(Main$, I% + 1, 1)) NEXT DEF SEG END SUB SUB PrintDBFRecord (FV$(), RecNum) '------------------------------------------------- 'Purpose: Print the record to the screen. Left - ' justify character, date and logical - ' fields. Right justify numeric fields - ' and ignore memo fields - 'Input : Field values store in character array, - ' current record number - '------------------------------------------------- ' Print rec # & delete status ColumnSpace = 4 'Room between columns PRINT USING "####### !"; RecNum; FV$(0); ColumnLocation = 10 'Set current location FOR I = 1 TO DBFHdr.NumberFields IF Flds(I).FdType <> "M" THEN PRINT TAB(ColumnLocation); IF Flds(I).FdType = "N" OR Flds(I).FdType = "F" THEN PRINT RightJust$(FV$(I), Flds(I).FdLength); ELSE PRINT FV$(I); END IF ' Set next print location ColumnLocation = ColumnLocation + Flds(I).FdLength + ColumnSpace END IF NEXT I PRINT END SUB SUB PrintReport '------------------------------------------------- 'Purpose: Main printing routine - 'Calls : ReadDbfRecord - ' PrintDbfRecord - '------------------------------------------------- REDIM FieldValues$(DBFHdr.NumberFields) PRINT : PRINT PRINT "Report on the "; FileName$; " file" PRINT FOR I = 1 TO DBFHdr.NumberRecords CALL ReadDBFRecord(FieldValues$()) CALL PrintDBFRecord(FieldValues$(), I) NEXT I END SUB FUNCTION ReadDBFHdr '------------------------------------------------- 'Purpose: Read the dBASE file header information - ' and store in the header record - '------------------------------------------------- HdrStr$ = SPACE$(32) GET #1, , HdrStr$ 'Read dBASE Header DBFHdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7) UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1))) UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1))) UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1))) DBFHdr.LastUpdate = UpdMM$ + "/" + UpdDD$ + "/" + UpdYY$ DBFHdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4)) DBFHdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2)) DBFHdr.RecordLength = CVI(MID$(HdrStr$, 11, 2)) DBFHdr.NumberFields = (DBFHdr.HeaderLength - 33) / 32 DBFHdr.FileSize = DBFHdr.HeaderLength + DBFHdr.RecordLength * DBFHdr.NumberRecords + 1 IF DBFHdr.VersionNumber <> 3 THEN ReadDBFHdr = 1 'Not a dBASE file EXIT FUNCTION END IF IF DBFHdr.NumberRecords = 0 THEN ReadDBFHdr = 2 'No records EXIT FUNCTION END IF ReadDBFHdr = 0 'No errors END FUNCTION SUB ReadDBFRecord (FV$()) '------------------------------------------------- 'Purpose: Read a dBASE record, format date and - ' logical fields for output - 'Input : Array of Field values - '------------------------------------------------- F$ = SPACE$(DBFHdr.RecordLength) GET #1, , F$ 'Read the record FV$(0) = LEFT$(F$, 1) 'Read deleted record mark FPOS = 2 FOR I = 1 TO DBFHdr.NumberFields FV$(I) = MID$(F$, FPOS, Flds(I).FdLength) SELECT CASE Flds(I).FdType 'Adjust field types CASE "D" 'Modify date format Y$ = LEFT$(FV$(I), 4) M$ = MID$(FV$(I), 5, 2) D$ = RIGHT$(FV$(I), 2) FV$(I) = M$ + "/" + D$ + "/" + Y$ CASE "L" 'Standardize T or F SELECT CASE UCASE$(FV$(I)) CASE "Y", "T": FV$(I) = ".T." CASE "N", "F": FV$(I) = ".F." CASE ELSE: FV$(I) = ".?." END SELECT CASE ELSE END SELECT FPOS = FPOS + Flds(I).FdLength 'Set next fld 'PRINT FV$(I) NEXT I END SUB FUNCTION ReadFileStructure '------------------------------------------------- 'Purpose: Read the file structure store in the - ' dBASE file header. - '------------------------------------------------- FOR I = 1 TO DBFHdr.NumberFields Fld$ = SPACE$(32) GET #1, , Fld$ 'Get field info string Flds(I).FdName = LEFT$(Fld$, 11) Flds(I).FdType = MID$(Fld$, 12, 1) Flds(I).FdLength = ASC(MID$(Fld$, 17, 1)) Flds(I).FdDec = ASC(MID$(Fld$, 18, 1)) NEXT I HeaderTerminator$ = INPUT$(1, #1) 'Last hdr byte IF ASC(HeaderTerminator$) <> 13 THEN ReadFileStructure = False 'Bad Dbf header END IF ReadFileStructure = True END FUNCTION FUNCTION RightJust$ (Value$, FieldWidth) '------------------------------------------------- 'Purpose: Right justify a string by padding it - ' with spaces on the left - 'Input : The character value to justify, the - ' width of the field to fit - 'Output : A right justified string to print - '------------------------------------------------- RightJust$ = RIGHT$(STRING$(FieldWidth, " ") + Value$, FieldWidth) END FUNCTION '------------------------------------------------------------------------------ FUNCTION SBreset% OUT BlasterAddr% + &H6, 1 'Reset address WDelay .1 OUT BlasterAddr% + &H6, 0 Time1! = TIMER: NoReset% = 0 DO 'Read Data Available port until bit 7 is set 'This should take about 100 micro seconds...give it 1 full second IF TIMER - Time1! > 1! THEN NoReset% = -1 LOOP UNTIL ((INP(BlasterAddr% + &HE) AND 128) = 128) OR NoReset% IF NOT NoReset% THEN IF INP(BlasterAddr% + &HA) = &HAA THEN SBreset% = -1 ELSE SBreset% = 0 END IF ELSE SBreset% = 0 END IF END FUNCTION SUB ShowBMP (FileName$) VA = &H3C8 VD = &H3C9 OPEN FileName$ FOR BINARY AS #1 Header$ = SPACE$(14) Sizing$ = SPACE$(4) GET #1, 1, Header$ IF LEN(Header$) = 0 THEN PRINT "Not a valid Bitmap file.": CLOSE : EXIT SUB IF MID$(Header$, 1, 2) <> "BM" THEN PRINT "Not a valid Bitmap file.": CLOSE : EXIT SUB GET #1, 15, Sizing$ BMPInfoSize = CVI(Sizing$) IF BMPInfoSize = 12 THEN InfoHeader$ = SPACE$(12) GET #1, 15, InfoHeader$ NBits = CVI(MID$(InfoHeader$, 15, 4)) IF NBits = 1 THEN Palet$ = SPACE$(6) GET #1, BMPInfoSize + 15, Palet$ ELSEIF NBits = 4 THEN Palet$ = SPACE$(48) GET #1, BMPInfoSize + 15, Palet$ ELSEIF NBits = 8 THEN Palet$ = SPACE$(768) GET #1, BMPInfoSize + 15, Palet$ END IF ELSEIF BMPInfoSize = 40 THEN InfoHeader$ = SPACE$(40) GET #1, 15, InfoHeader$ NBits = CVI(MID$(InfoHeader$, 15, 4)) IF NBits = 1 THEN Palet$ = SPACE$(8) GET #1, BMPInfoSize + 15, Palet$ ELSEIF NBits = 4 THEN Palet$ = SPACE$(64) GET #1, BMPInfoSize + 15, Palet$ ELSEIF NBits = 8 THEN Palet$ = SPACE$(1024) GET #1, BMPInfoSize + 15, Palet$ END IF END IF BMPFT$ = MID$(Header$, 1, 2) FileSize = CVL(MID$(Header$, 3, 4)) R1 = CVI(MID$(Header$, 7, 2)) R2 = CVI(MID$(Header$, 9, 2)) Offset = CVL(MID$(Header$, 11, 4)) HeaderSize = CVL(MID$(InfoHeader$, 1, 4)) PicWidth = CVL(MID$(InfoHeader$, 5, 4)) PicHeight = CVL(MID$(InfoHeader$, 9, 4)) NPlanes = CVI(MID$(InfoHeader$, 13, 4)) 'PRINT "Type of file (Should be BM): "; BMPFT$ 'PRINT "Size of file: "; FileSize 'PRINT "Reserved 1: "; R1 'PRINT "Reserved 2: "; R2 'PRINT "Number of bytes offset from beginning: "; Offset 'PRINT "Size of header: "; HeaderSize 'PRINT "Width: "; PicWidth 'PRINT "Height: "; PicHeight 'PRINT "Planes: "; NPlanes 'PRINT "Bits per plane: "; NBits 'IF CompType = 0 THEN PRINT "Compression: None" 'IF CompType = 1 THEN PRINT "Compression: Run Length - 8 Bits" 'IF CompType = 2 THEN PRINT "Compression: Run Length - 4 Bits" 'PRINT "Image Size (bytes): "; ImageSize 'PRINT "X size (pixels per metre): "; XSize 'PRINT "Y size (pixels per metre): "; YSize 'PRINT "Number of colours used: "; ColorsUsed 'PRINT "Number of important colours: "; NeededColours IF HeaderSize = 40 THEN CompType = CVL(MID$(InfoHeader$, 17, 4)) ImageSize = CVL(MID$(InfoHeader$, 21, 4)) XSize = CVL(MID$(InfoHeader$, 25, 4)) YSize = CVL(MID$(InfoHeader$, 29, 4)) ColorsUsed = CVL(MID$(InfoHeader$, 33, 4)) NeededColours = CVL(MID$(InfoHeader$, 37, 4)) END IF IF NBits = 1 THEN SCREEN 11 XRes = 640 YRes = 480 NC = 2 ELSEIF NBits = 4 THEN SCREEN 12 XRes = 640 YRes = 480 NC = 16 ELSEIF NBits = 8 OR NBits = 24 THEN SCREEN 13 XRes = 320 YRes = 200 NC = 256 END IF IF BMPInfoSize = 40 THEN NGroups = 4 IF BMPInfoSize = 12 THEN NGroups = 3 IF NBits = 24 THEN IF Grey = 1 THEN IF NGroups = 3 THEN FOR C = 0 TO 63 D = C * 4 Palet$ = Palet$ + CHR$(D) + CHR$(D) + CHR$(D) Palet$ = Palet$ + CHR$(D) + CHR$(D) + CHR$(D + 1) Palet$ = Palet$ + CHR$(D) + CHR$(D + 1) + CHR$(D) Palet$ = Palet$ + CHR$(D + 1) + CHR$(D) + CHR$(D) NEXT C ELSEIF NGroups = 4 THEN FOR C = 0 TO 63 D = C * 4 Palet$ = Palet$ + CHR$(D) + CHR$(D) + CHR$(D) + CHR$(0) Palet$ = Palet$ + CHR$(D) + CHR$(D) + CHR$(D + 1) + CHR$(0) Palet$ = Palet$ + CHR$(D) + CHR$(D + 1) + CHR$(D) + CHR$(0) Palet$ = Palet$ + CHR$(D + 1) + CHR$(D) + CHR$(D) + CHR$(0) NEXT C END IF ELSE FOR T = 0 TO 5 FOR U = 0 TO 5 FOR V = 0 TO 5 Palet$ = Palet$ + CHR$(INT(V * (256 / 6))) Palet$ = Palet$ + CHR$(INT(U * (256 / 6))) Palet$ = Palet$ + CHR$(INT(T * (256 / 6))) IF NGroups = 4 THEN Palet$ = Palet$ + CHR$(0) NEXT V NEXT U NEXT T FOR Count = 0 TO 31 Palet$ = Palet$ + CHR$(Count * 8) + CHR$(Count * 8) + CHR$(Count * 8) IF NGroups = 4 THEN Palet$ = Palet$ + CHR$(0) NEXT Count Palet$ = Palet$ + CHR$(255) + CHR$(255) + CHR$(255) END IF END IF OUT VA, 0 FOR X = 1 TO LEN(Palet$) STEP NGroups ZB = INT((ASC(MID$(Palet$, X, 1))) / 4) ZG = INT((ASC(MID$(Palet$, X + 1, 1))) / 4) ZR = INT((ASC(MID$(Palet$, X + 2, 1))) / 4) OUT VD, ZR OUT VD, ZG OUT VD, ZB NEXT X IF CompType = 0 THEN 'No Compression IF NBits = 24 THEN Y = PicHeight - 1 X = 0 Lin$ = SPACE$((INT((3 * PicWidth - 1) / 4) + 1) * 4) WHILE Y >= 0 GET 1, , Lin$ IF Grey = 0 THEN WHILE X < PicWidth B = ASC(MID$(Lin$, X * 3 + 1, 1)) G = ASC(MID$(Lin$, X * 3 + 2, 1)) R = ASC(MID$(Lin$, X * 3 + 3, 1)) IF B = G AND G = R THEN P1 = INT(B / 8) + 216 IF B = 255 THEN P1 = 247 ELSE R = INT(R * (6 / 256)) G = INT(G * (6 / 256)) B = INT(B * (6 / 256)) QA = INT(RND(1) * (R + 1)) * .4 QB = INT(RND(1) * (G + 1)) * .4 QC = INT(RND(1) * (B + 1)) * .4 R = INT(R + QA - (R * .2)) G = INT(G + qg - (G * .2)) B = INT(B + QB - (B * .2)) IF R > 5 THEN R = 5 IF R < 0 THEN R = 0 IF G > 5 THEN G = 5 IF G < 0 THEN G = 0 IF B > 5 THEN B = 5 IF B < 0 THEN B = 0 P1 = R * 36 + G * 6 + B END IF PSET (X, Y), P1 X = X + 1 WEND ELSE WHILE X < PicWidth P1 = INT((ASC(MID$(Lin$, X * 3 + 1, 1)) + ASC(MID$(Lin$, X * 3 + 2, 1)) + ASC(MID$(Lin$, X * 3 + 3, 1))) / 3) PSET (X, Y), P1 X = X + 1 WEND END IF Y = Y - 1 X = 0 WEND ELSEIF NBits = 8 THEN Y = PicHeight - 1 X = 0 Lin$ = SPACE$((INT((PicWidth - 1) / 4) + 1) * 4) WHILE Y >= 0 GET #1, , Lin$ WHILE X < PicWidth CO = ASC(MID$(Lin$, X + 1, 1)) PSET (X, Y), CO X = X + 1 WEND Y = Y - 1 X = 0 WEND ELSEIF NBits = 4 THEN Y = PicHeight - 1 X = 0 Lin$ = SPACE$((INT((PicWidth - 1) / 8) + 1) * 4) WHILE Y >= 0 GET 1, , Lin$ WHILE X < PicWidth P2 = ASC(MID$(Lin$, INT(X / 2) + 1, 1)) AND 15 P1 = (ASC(MID$(Lin$, INT(X / 2) + 1, 1)) AND 240) / 16 PSET (X, Y), P1 IF X + 1 < PicWidth THEN PSET (X + 1, Y), P2 X = X + 2 WEND Y = Y - 1 X = 0 WEND ELSEIF NBits = 1 THEN Y = PicHeight - 1 X = 0 Lin$ = SPACE$((INT((PicWidth - 1) / 32) + 1) * 4) WHILE Y >= 0 GET 1, , Lin$ WHILE X < PicWidth P8 = ASC(MID$(Lin$, INT(X / 8) + 1, 1)) FOR B = 0 TO 7 IF X + (7 - B) < PicWidth THEN PSET (X + (7 - B), Y), (P8 AND 2 ^ B) / 2 ^ B NEXT B X = X + 8 WEND Y = Y - 1 X = 0 WEND END IF ELSEIF CompType = 1 THEN 'Compression Essentials '[a][b] a>0, repeat b a-times '[0][0] End of line '[0][1] End of bitmap '[0][2][h][v] Move current position h to the right and v down 'PRINT "Wow! RLE-8 Compression." A$ = " " X = 0 Y = 0 EF = 0 WHILE EF = 0 GET #1, , A$ C = ASC(A$) IF C > 0 THEN GET #1, , A$ B = ASC(A$) FOR Count = 1 TO C PSET (PicWidth - X - 1, PicHeight - Y - 1), B X = X + 1 NEXT Count ELSE GET #1, , A$ C = ASC(A$) IF C = 0 THEN X = 0 Y = Y + 1 ELSEIF C = 1 THEN EF = 1 ELSEIF C = 2 THEN GET #1, , A$ H = ASC(A$) GET #1, , A$ V = ASC(A$) X = X + H Y = Y + V ELSE FOR Count = 1 TO C GET #1, , A$ P1 = ASC(A$) PSET (PicWidth - X - 1, PicHeight - Y - 1), P1 X = X + 1 NEXT Count IF C MOD 2 = 1 THEN GET #1, , A$ END IF IF (Y = PicHeight - 1 AND X >= PicWidth) OR Y >= PicHeight THEN EF = 1 END IF IF EOF(1) THEN EF = 1 WEND ELSEIF CompType = 2 THEN 'Compression Essentials '[a][b1|b0] a>0, repeat b1|b0 a/2-times e.g. a=5 -> b1 b0 b1 b0 b1 '[0][0] End of line '[0][1] End of bitmap '[0][2][h][v] Move current position h to the right and v down 'PRINT "Wow! RLE-4 Compression." A$ = " " X = 0 Y = 0 EF = 0 WHILE EF = 0 GET #1, , A$ C = ASC(A$) IF C > 0 THEN GET #1, , A$ B = ASC(A$) FOR Count = 1 TO C IF (Count MOD 2) = 0 THEN PSET (PicWidth - X - 1, PicHeight - Y - 1), B AND 15 ELSE PSET (PicWidth - X - 1, PicHeight - Y - 1), (B AND 240) / 16 END IF X = X + 1 NEXT Count ELSE GET #1, , A$ C = ASC(A$) IF C = 0 THEN X = 0 Y = Y + 1 ELSEIF C = 1 THEN EF = 1 ELSEIF C = 2 THEN GET #1, , A$ H = ASC(A$) GET #1, , A$ V = ASC(A$) X = X + H Y = Y + V ELSE FOR Count = 1 TO INT(C / 2) GET #1, , A$ P1 = ASC(A$) PSET (PicWidth - X - 1, PicHeight - Y - 1), (P1 AND 240) / 16 X = X + 1 PSET (PicWidth - X - 1, PicHeight - Y - 1), P1 AND 15 X = X + 1 NEXT Count BR = INT(C / 2) IF (C MOD 2) = 1 THEN GET #1, , A$ PSET (PicWidth - X - 1, PicHeight - Y - 1), (P1 AND 240) / 16 X = X + 1 BR = BR + 1 END IF IF BR MOD 2 = 1 THEN GET #1, , A$ END IF IF (Y = PicHeight - 1 AND X >= PicWidth) OR Y >= PicHeight THEN EF = 1 END IF IF EOF(1) THEN EF = 1 WEND END IF CLOSE END SUB SUB ShowBox (Comm$) '========================================================== TextClr = 1 WindowClr = 0 ScrollBarClr = 4 BackGround = 7 '========================================================== REDIM ShowBoxText$(900) Comm$ = RTRIM$(LTRIM$(Comm$)) ON ERROR GOTO TooLong OPEN Comm$ FOR INPUT AS #1 WHILE NOT EOF(1) LINE INPUT #1, Temp$ TotLen = TotLen + LEN(Temp$) + 2 FOR Lp = 1 TO 2 FOR M = 1 TO LEN(Temp$) IF LEN(Temp$) > 0 THEN LS$ = LEFT$(Temp$, M) ELSE LS$ = "" IF LEN(Temp$) > 0 THEN RS$ = RIGHT$(Temp$, LEN(Temp$) + 1 - M) ELSE RS$ = "" IF RS$ <> "" THEN RS$ = RIGHT$(RS$, LEN(RS$) - 1) IF LS$ <> "" THEN LS$ = LEFT$(LS$, LEN(LS$) - 1) IF MID$(Temp$, M, 1) = CHR$(9) THEN Temp$ = LS$ + SPACE$(8 - (M MOD 8)) + RS$ END IF NEXT M NEXT Lp T$ = "" IF LEN(Temp$) > MaxX THEN MaxX = LEN(Temp$) ShowBoxText$(I) = Temp$ I = I + 1 PercentRead = INT(100 / LOF(1) * TotLen) PR$ = RIGHT$(STR$(PercentRead), LEN(STR$(PercentRead)) - 1) IF PercentRead MOD 1 = 0 THEN LOCATE CSRLIN - 1, 17: PRINT PR$; "%" WEND LOCATE CSRLIN - 1, 17: PRINT "100%" MaxX = MaxX + 1 IF MaxX < 79 THEN MaxX = 79 CLOSE 1 ON ERROR GOTO 0 EndLine = I - 21 IF EndLine < 1 THEN EndLine = 1: NoMove = 1 TLine = EndLine IF BackGround > 7 THEN BTextClr = TextClr + 16 BWindowClr = WindowClr + 16 BScrollBarClr = ScrollBarClr + 16 ELSE BTextClr = TextClr BWindowClr = WindowClr BScrollBarClr = ScrollBarClr END IF GOSUB BrightBG MaxX = 0 FOR Y = 0 TO TLine IF LEN(ShowBoxText$(Y)) > MaxX THEN MaxX = LEN(ShowBoxText$(Y)) NEXT Y NoHScroll = 0 IF MaxX < 76 THEN NoHScroll = 1 XPos = 1 LineText = 0 SliderPos = 0 SliderHPos = 0 EndLine = TLine IF EndLine < 1 THEN EndLine = 1: NoMove = 1 SliderTop = 3 SliderBottom = 23 SliderCol = 80 SliderMax = TLine SliderHLeft = 2 SliderHRight = 79 SliderHRow = 24 SliderHMax = MaxX - 77 IF SliderHMax <= 1 THEN SliderHMax = 2: NoHScroll = 1 IF SliderMax <= 21 THEN SliderMax = 21: NoVScroll = 1 COLOR BackGround FOR I = 1 TO 25 LOCATE I, 1: PRINT STRING$(80, "Û"); NEXT I COLOR BWindowClr, BackGround IF LEN(Comm$) > 47 THEN Comm$ = "..." + RIGHT$(Comm$, 44) FileToShow$ = " File:> " + Comm$ Lb1$ = "É" + STRING$(55, "Í") + "Ê" + STRING$(22, "Í") + "»" Top$ = FileToShow$ + SPACE$(56 - LEN(FileToShow$)) + "º [Esc] To Quit Viewer " Bottom$ = " SHOW V2.9 - (C)Copyright 1997 by Christopher Fry [Press F1 for Help] " NHSB$ = "Ì" + STRING$(78, "Í") + "¹" LOCATE 1, 1: PRINT Top$; LOCATE 2, 1: PRINT Lb1$; LOCATE 25, 2: PRINT Bottom$; FOR SideB = 3 TO 25 LOCATE SideB, 1: PRINT "º"; NEXT SideB LOCATE 24, 1: PRINT "Ì"; IF NoHScroll = 1 THEN LOCATE 24, 1: PRINT NHSB$; IF NoVScroll = 1 THEN FOR SideB = 3 TO 23 LOCATE SideB, 80: PRINT "º"; NEXT SideB END IF LOCATE 24, 80: PRINT "¹"; LOCATE 25, 80: PRINT "º"; OldSDP = 0: OldHSDP = 0 SliderPos = LineText SliderHPos = XPos GOSUB DrawSliders COLOR BTextClr, BackGround FOR I = 3 TO 23 LOCATE I, 2: PRINT MID$(ShowBoxText$(LineText + I - 3), XPos, 78); NEXT I WHILE Choose$ <> CHR$(27) Choose$ = UCASE$(INKEY$) Move = 0 IF NoVScroll = 0 THEN IF NoMove = 0 AND Choose$ = CHR$(0) + "P" THEN LineText = LineText + 1: Move = 1 IF NoMove = 0 AND Choose$ = CHR$(0) + "H" THEN LineText = LineText - 1: Move = 1 IF NoMove = 0 AND Choose$ = CHR$(0) + "Ž" AND LineText <> 0 THEN LineText = 0: Move = 1 IF NoMove = 0 AND Choose$ = CHR$(0) + "V" AND LineText <> EndLine THEN LineText = EndLine: Move = 1 IF NoMove = 0 AND Choose$ = CHR$(0) + "I" AND LineText <> 0 THEN LineText = LineText - (21): Move = 2 IF NoMove = 0 AND Choose$ = CHR$(0) + "Q" AND LineText <> EndLine THEN LineText = LineText + (21): Move = 2 END IF IF NoHScroll = 0 THEN IF Choose$ = CHR$(0) + "M" AND XPos <> MaxX - 77 THEN XPos = XPos + 1: Move = 1 IF Choose$ = CHR$(0) + "K" AND XPos <> 1 THEN XPos = XPos - 1: Move = 1 IF Choose$ = CHR$(0) + "G" AND XPos <> 1 THEN XPos = 1: Move = 1 IF Choose$ = CHR$(0) + "O" AND XPos <> MaxX - 77 THEN XPos = MaxX - 77: Move = 1 IF XPos < 1 THEN XPos = 1: Move = 0 IF XPos > MaxX - 77 THEN XPos = MaxX - 77: Move = 0 END IF IF Choose$ = "W" THEN GOSUB ChangeColourW IF Choose$ = "S" THEN GOSUB ChangeColourS IF Choose$ = "T" THEN GOSUB ChangeColourT IF Choose$ = "B" THEN GOSUB ChangeColourB IF Choose$ = CHR$(0) + ";" THEN GOSUB CommandHelp IF Choose$ = "P" THEN GOSUB PrintDoc IF LineText < 0 THEN LineText = 0: IF Move = 1 THEN Move = 0 IF LineText > EndLine AND NoMove = 0 THEN LineText = EndLine: IF Move = 1 THEN Move = 0 IF LineText = EndLine AND NoMove = 1 THEN LineText = 0: Move = 0 IF Move > 0 THEN COLOR BTextClr, BackGround FOR I = 3 TO 23 LOCATE I, 2: PRINT SPACE$(78); NEXT I FOR I = 3 TO 23 LOCATE I, 2: PRINT MID$(ShowBoxText$(LineText + I - 3), XPos, 78); NEXT I SliderPos = LineText SliderHPos = XPos GOSUB DrawSliders END IF WEND GOSUB ClearScreen GOSUB FlashyFG ERASE ShowBoxText$ EXIT SUB ChangeColourB: BackGround = BackGround + 1 IF BackGround = 16 THEN BackGround = 0 GOSUB RedrawScreen RETURN ChangeColourT: TextClr = TextClr + 1 IF TextClr = 16 THEN TextClr = 0 GOSUB RedrawScreen RETURN ChangeColourW: WindowClr = WindowClr + 1 IF WindowClr = 16 THEN WindowClr = 0 GOSUB RedrawScreen RETURN ChangeColourS: ScrollBarClr = ScrollBarClr + 1 IF ScrollBarClr = 16 THEN ScrollBarClr = 0 GOSUB RedrawScreen RETURN DrawSliders: IF NoVScroll = 0 THEN COLOR BWindowClr, BackGround SlideDotPos = INT(((SliderBottom - SliderTop) / SliderMax * SliderPos) + SliderTop) IF OldSDP <> SlideDotPos THEN FOR SlideY = SliderTop TO SliderBottom LOCATE SlideY, SliderCol: PRINT "±"; NEXT SlideY COLOR BScrollBarClr, WindowClr LOCATE SlideDotPos, SliderCol: PRINT CHR$(18); OldSDP = SlideDotPos END IF ELSE COLOR BWindowClr, BackGround FOR SideB = 3 TO 23 LOCATE SideB, 80: PRINT "º"; NEXT SideB END IF IF NoHScroll = 0 THEN COLOR BWindowClr, BackGround SlideHDotPos = (INT((((SliderHPos - 1) / (SliderHMax - 1))) * (SliderHRight - SliderHLeft)) + SliderHLeft) IF OldHSDP <> SlideHDotPos THEN LOCATE SliderHRow, SliderHLeft: PRINT STRING$((SliderHRight - SliderHLeft + 1), "±"); COLOR BScrollBarClr, WindowClr LOCATE SliderHRow, SlideHDotPos: PRINT CHR$(18); OldHSDP = SlideHDotPos END IF ELSE COLOR BWindowClr, BackGround LOCATE 24, 1: PRINT NHSB$; END IF RETURN FlashyFG: Regs.AX = &H1003 Regs.BX = 1 CALL zzBasicInt(&H10) RETURN BrightBG: Regs.AX = &H1003 Regs.BX = 0 CALL zzBasicInt(&H10) RETURN RedrawScreen: IF BackGround > 7 THEN BTextClr = TextClr + 16 BWindowClr = WindowClr + 16 BScrollBarClr = ScrollBarClr + 16 ELSE BTextClr = TextClr BWindowClr = WindowClr BScrollBarClr = ScrollBarClr END IF COLOR BackGround FOR I = 1 TO 25 LOCATE I, 1: PRINT STRING$(80, "Û"); NEXT I COLOR BWindowClr, BackGround LOCATE 1, 1: PRINT Top$; LOCATE 2, 1: PRINT Lb1$; LOCATE 25, 2: PRINT Bottom$; FOR SideB = 3 TO 25 LOCATE SideB, 1: PRINT "º"; NEXT SideB LOCATE 24, 1: PRINT "Ì"; IF NoHScroll = 1 THEN LOCATE 24, 1: PRINT NHSB$; IF NoVScroll = 1 THEN FOR SideB = 3 TO 23 LOCATE SideB, 80: PRINT "º"; NEXT SideB END IF LOCATE 24, 80: PRINT "¹"; LOCATE 25, 80: PRINT "º"; OldSDP = 0: OldHSDP = 0 GOSUB DrawSliders COLOR BTextClr, BackGround FOR I = 3 TO 23 LOCATE I, 2: PRINT MID$(ShowBoxText$(LineText + I - 3), XPos, 78); NEXT I RETURN CommandHelp: IF WindowClr > 7 THEN ForeClr = ScrollBarClr + 16 ELSE ForeClr = ScrollBarClr COLOR WindowClr FOR I = 6 TO 19 LOCATE I, 8: PRINT STRING$(65, "Û"); NEXT I COLOR ForeClr, WindowClr FOR Row = 7 TO 18 LOCATE Row, 8: PRINT "º"; LOCATE Row, 72: PRINT "º"; NEXT Row LOCATE 6, 8: PRINT "É" + STRING$(63, "Í") + "»"; LOCATE 19, 8: PRINT "È" + STRING$(63, "Í") + "¼"; CALL ziCenter(7, "°±²Û²±°±²Û²±°±²Û²±° úùÄÍ KEYS ÍÄùú °±²Û²±°±²Û²±°±²Û²±°") LOCATE 9, 10: PRINT "[" + CHR$(24) + CHR$(25) + CHR$(26) + CHR$(27) + "] - Scroll through text in cursor direction"; LOCATE 11, 10: PRINT "[TBWS] - Scroll through colours"; LOCATE 12, 32: PRINT "(Text,Back,Window,Scrollbar)"; LOCATE 14, 10: PRINT "[Pg Up/Down] - Page Up and Down through text"; LOCATE 15, 10: PRINT "[Home/End] - Goto furthest left and right of text"; LOCATE 16, 10: PRINT "[Ctrl]+[Pg Up/Down] - Goto top and bottom of text"; LOCATE 18, 10: PRINT "[P] - Print Document"; Mopup$ = INKEY$ A$ = INPUT$(1) GOSUB RedrawScreen RETURN PrintDoc: IF WindowClr > 7 THEN ForeClr = ScrollBarClr + 16 ELSE ForeClr = ScrollBarClr COLOR WindowClr FOR I = 10 TO 15 LOCATE I, 20: PRINT STRING$(41, "Û"); NEXT I COLOR ForeClr, WindowClr FOR Row = 11 TO 14 LOCATE Row, 20: PRINT "º"; LOCATE Row, 60: PRINT "º"; NEXT Row LOCATE 10, 20: PRINT "É" + STRING$(39, "Í") + "»"; LOCATE 15, 20: PRINT "È" + STRING$(39, "Í") + "¼"; ' "CON" , "LTP1:" , File$ CALL ziCenter(12, " >> PRINTING << ") OPEN "LPT1:" FOR OUTPUT AS #9 FOR B = 1 TO EndLine PRINT #9, ShowBoxText$(B) NEXT B PRINT #9, CHR$(&H1A) CLOSE 9 CALL ziCenter(13, "Press any key to continue") Mopup$ = INKEY$ A$ = INPUT$(1) GOSUB RedrawScreen RETURN ClearScreen: COLOR 7, 0 FOR ColPos = 1 TO 80 STEP .99 FOR RowPos = 1 TO 25 C = INT(ColPos / 25 * RowPos) IF C > 0 THEN LOCATE RowPos, C: PRINT " "; LOCATE 26 - RowPos, 81 - C: PRINT " "; END IF NEXT RowPos NEXT ColPos RETURN END SUB SUB ShowDBase (FileName$) OPEN FileName$ FOR BINARY AS #1 CLS ActionHdr = ReadDBFHdr REDIM Flds(DBFHdr.NumberFields) AS DBFFieldInfoType SELECT CASE ActionHdr CASE 1 BEEP PRINT "Not a dBASE III+ or IV file" CASE ELSE DSPDBFInfo DBFPause ActionFile = ReadFileStructure SELECT CASE ActionFile CASE True CLS DSPFileStructure DBFPause IF ActionHdr <> 2 THEN CLS PrintReport ELSE CLS PRINT "No records to print" END IF CASE False BEEP PRINT "Field information error" END SELECT END SELECT CLOSE #1 END SUB SUB StopMIDI IF MIDI.Interrupt = 0 THEN MIDI.Interrupt = &H81 A$ = Int86QB$(MIDI.Interrupt, 0, 0, &H502, 0, 0, 0, 0, 0, 0, 0) MIDI.PlayTime = 0 END SUB FUNCTION TimeMIDI! IF MIDI.PlayTime THEN CurrentTime! = TIMER IF CurrentTime! - MIDI.PlayTime < 0 THEN CurrentTime! = 86400 + CurrentTime! END IF TimeMIDI! = CurrentTime! - MIDI.PlayTime END IF END FUNCTION FUNCTION UInt (A$) A = ASC(MID$(A$, 1, 1)) + ASC(MID$(A$, 2, 1)) * 256 UInt = A END FUNCTION '------------------------------------------------------------------------------ SUB ValidWavHeader (File$, LenHeader%, DataLen&, NChannels%, NSamplesPerSec&, NAvgBytesPerSec&, OK%) rID$ = SPACE$(4) wID$ = SPACE$(4) fID$ = SPACE$(4) Dat$ = SPACE$(4) Dummy$ = SPACE$(1) FileNum% = FREEFILE OPEN File$ FOR BINARY AS FileNum% GET FileNum%, , rID$ GET FileNum%, , rLen& GET FileNum%, , wID$ GET FileNum%, , fID$ GET FileNum%, , fLen& GET FileNum%, , wFormatTag% '2 bytes GET FileNum%, , NChannels% '2 bytes GET FileNum%, , NSamplesPerSec& '4 bytes GET FileNum%, , NAvgBytesPerSec& '4 bytes GET FileNum%, , NBlockAlign% '2 bytes GET FileNum%, , FormatSpecific% '2 bytes 'Read bytes until have read fLen& total bytes. 'I have no idea what these next bytes are used for (if they even exist). FOR I% = 1 TO fLen& - 16 '16 bytes is what we have read in so far GET FileNum%, , Dummy$ 'read in 1 byte at a time NEXT I% GET FileNum%, , Dat$ IF UCASE$(Dat$) = "FACT" THEN 'funny format... GET FileNum%, , Dummy& GET FileNum%, , Dummy& GET FileNum%, , Dat$ END IF GET FileNum%, , DataLen& LenHeader% = LOC(1) CLOSE FileNum% IF UCASE$(rID$) = "RIFF" THEN IF UCASE$(wID$) = "WAVE" THEN IF UCASE$(Dat$) = "DATA" THEN IF UCASE$(fID$) = "FMT " THEN IF FormatSpecific% = 8 THEN OK% = -1 END IF END IF END IF END IF END SUB '------------------------------------------------------------------------------ SUB WDelay (DelayT!) Time1! = TIMER DO LOOP WHILE (TIMER - Time1! < DelayT!) OR (Time1! > TIMER) END SUB '------------------------------------------------------------------------------ SUB WriteToDSP (V%) DO LOOP UNTIL (INP(BlasterAddr% + &HC) AND 128) = 0 OUT BlasterAddr% + &HC, V% END SUB DEFSNG A-Z FUNCTION ZeroJust$ (Number AS INTEGER) '------------------------------------------------- 'Purpose: Add a leading zero to numbers less - ' than 10 so they take as much room as - ' numbers 10 and larger - 'Input : The number to standardize - 'Output : The adjusted number - '------------------------------------------------- N$ = STR$(Number) LengthN = LEN(N$) - 1'Subtract 1 for leading space N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2) ZeroJust$ = N$ END FUNCTION DEFINT A-Z SUB ziCenter (Row, Text$) LOCATE Row, 41 - LEN(Text$) / 2: PRINT Text$; END SUB '++++++++++++++++++++++++ SUB ziExhaust DO X$ = INKEY$ LOOP WHILE LEN(X$) IF Mouse AND MCursorVis THEN DO Regs.AX = 3 CALL zzBasicInt(&H33) LOOP WHILE (Regs.BX AND 3) END IF Response = 0 END SUB '++++++++++++++++++++++++ SUB ziLoadFont (Font$) DEF SEG = VARSEG(Font(0, 0)) Module$ = Font$ + ".OVL" CALL zzInPath(Module$) IF Module$ = "" THEN Module$ = Font$ + ".OVL" ERROR 255 ELSE BLOAD Module$, VARPTR(Font(0, 0)) END IF DEF SEG END SUB '++++++++++++++++++++++++ SUB ziLocateMCursor (Xcoord, YCoord) IF Mouse THEN MXLoc = Xcoord MYLoc = YCoord Regs.AX = 4 Regs.CX = Xcoord Regs.DX = YCoord CALL zzBasicInt(&H33) CALL ziSetMCursorVis(1) END IF END SUB '++++++++++++++++++++++++ SUB ziPublish (Printstring$, Size, italic) CALL ziSetMCursorVis(10) xx = POINT(0) yy = POINT(1) IF Size THEN Scale = Size ELSE Scale = 1 END IF LenString = LEN(Printstring$) ExpScale = 8 * Scale limxx = xx + ExpScale * LenString - 1 limyy = yy + ExpScale - 1 IF italic AND 1 THEN limxx = limxx + 4 * Scale END IF IF italic AND 2 THEN ELSE LINE (xx, yy)-(limxx, limyy), BG, BF END IF FOR A = 0 TO LenString - 1 X = ASC(MID$(Printstring$, A + 1, 1)) B = xx + ExpScale * A FOR Y = 0 TO 7 C = Font(X, Y) D = Y * Scale E = yy + D IF italic AND 1 THEN F = B + 4 * Scale - (D + Scale - 1) \ 2 - 1 ELSE F = B END IF G = 128 DO IF C AND G THEN FOR H = 0 TO Scale - 1 FOR I = 0 TO Scale - 1 PSET (F + H, E + I), FG NEXT NEXT END IF F = F + Scale G = G \ 2 LOOP UNTIL G = 0 NEXT NEXT CALL zsLocateGCursor(limxx + 1, yy) CALL ziSetMCursorVis(11) END SUB SUB ziPublishHere (Row, Col, Printstring$, Size, italic) IF Row + Col > 0 THEN LOCATE Row, Col END IF CALL zsAlignGCursor CALL ziPublish(Printstring$, Size, italic) CALL zsAlignTCursor END SUB '++++++++++++++++++++++++ SUB ziReadField (Min, Max, Permitted$) CALL ziSetMCursorVis(10) Rules$ = UCASE$(Permitted$) NoBlank = 0 IF INSTR(Rules$, "B") THEN NoBlank = 1 END IF atRow = CSRLIN atCol = POS(X) Field$ = "" PRINT CHR$(219); IF NoBlank = 0 THEN PRINT SPACE$(Max); Brake = 1 WHILE Brake X$ = "" WHILE LEN(X$) = 0 X$ = INKEY$ WEND IF INSTR(Rules$, "C") THEN X$ = UCASE$(X$) oldLen = LEN(Field$) Good = 0 IF INSTR(Rules$, "N") THEN IF INSTR("0123456789", X$) THEN Good = 1 END IF END IF IF INSTR(Rules$, "*") THEN IF INSTR(Allowed$, UCASE$(X$)) THEN Good = 1 END IF END IF IF Good THEN Field$ = Field$ + X$ NewMax = Max Field$ = MID$(Field$, 1, NewMax) END IF ' handle Bkspace IF ASC(X$) = 8 AND LEN(Field$) THEN Field$ = MID$(Field$, 1, LEN(Field$) - 1) END IF Signif$ = Field$ + "X" WHILE INSTR(" 0", MID$(Signif$, 1, 1)) Signif$ = MID$(Signif$, 2) WEND SignifLen = LEN(Signif$) - 1 ' handle Enter IF ASC(X$) = 13 AND SignifLen >= Min THEN oldLen = LEN(Field$) + 1 Brake = 0 END IF ' handle Esc IF ASC(X$) = 27 THEN LOCATE atRow, atCol PRINT CHR$(219); IF NoBlank = 0 THEN PRINT SPACE$(Max); ELSE PRINT STRING$(Max, ".") Field$ = "" IF INSTR(Rules$, "E") THEN RETURN END IF END IF ' reprint if change, or beep if no change IF oldLen = LEN(Field$) THEN BEEP ELSE LOCATE atRow, atCol PRINT Field$; CHR$(219); IF NoBlank = 0 THEN PRINT " "; ELSE PRINT "."; END IF ' check for auto-Enter WEND ' reprint, deleting the cursor LOCATE atRow, atCol PRINT Field$; IF NoBlank = 0 THEN PRINT " "; ELSE PRINT "."; CALL ziSetMCursorVis(11) END SUB '++++++++++++++++++++++++ SUB ziSetMCursorVis (Status) STATIC IF Mouse THEN SELECT CASE Status CASE 0 IF MCursorVis THEN Regs.AX = 2 CALL zzBasicInt(&H33) END IF CASE 1 MCursorVis = 1 Regs.AX = 1 CALL zzBasicInt(&H33) CASE 10 Regs.AX = &H2A CALL zzBasicInt(&H33) IF Regs.AX = 0 THEN TempFlag = 1 Regs.AX = 2 CALL zzBasicInt(&H33) ELSE TempFlag = 0 END IF CASE 11 IF TempFlag THEN Regs.AX = 1 CALL zzBasicInt(&H33) END IF END SELECT Regs.AX = &H2A CALL zzBasicInt(&H33) END IF END SUB '++++++++++++++++++++++++ SUB zsAlignGCursor Row = CSRLIN Col = POS(0) GXloc = (Col - 1) * ((XMax + 1) \ Cols) GYloc = (Row - 1) * (((YMax \ Rows) * Rows + 1) \ Rows) CALL zsLocateGCursor(GXloc, GYloc) END SUB '++++++++++++++++++++++++ SUB zsAlignTCursor GXloc = POINT(0) GYloc = POINT(1) A = (XMax + 1) / Cols B = (YMax + 1) / Rows Col = (GXloc + A - 1) \ A + 1 Row = (GYloc + B - 1) \ B + 1 LOCATE Row, Col CALL zsAlignGCursor END SUB '++++++++++++++++++++++++ SUB zsLocateGCursor (Xcoord, YCoord) GXloc = Xcoord GYloc = YCoord PSET (GXloc, GYloc), POINT(GXloc, GYloc) END SUB '++++++++++++++++++++++++ SUB zsSetScrnMode (Mode, HiRows, HiCols) CALL ziSetMCursorVis(10) ScrnMode = Mode IF Mode = 9 THEN SCREEN 9 IF HiRows THEN Rows = 43 ELSE Rows = 25 END IF XMax = 639 YMax = 349 END IF IF Mode = 12 THEN SCREEN 12 IF HiRows THEN Rows = 60 ELSE Rows = 30 END IF XMax = 639 YMax = 479 END IF IF HiCols THEN Cols = 80 ELSE Cols = 40 END IF WIDTH Cols, Rows CLS IF Mode = 9 THEN COLOR FG, BG ELSE COLOR FG END IF LINE (0, 0)-(XMax, YMax), BG, BF LOCATE 1, 1, 0 PSET (0, 0), BG XYratio! = .75 * (XMax + 1) / (YMax + 1) CALL ziSetMCursorVis(11) END SUB SUB zzAlphaSort (SortData$()) '++++++++++++++++++++++++ DIM SortPointers(SortCount, 2) FOR I = 2 TO SortCount j = 1 DO k = j IF SortData$(I) < SortData$(j) THEN j = SortPointers(j, 1) ELSE j = SortPointers(j, 2) END IF LOOP WHILE j <> 0 IF SortData$(I) < SortData$(k) THEN SortPointers(k, 1) = I ELSE SortPointers(k, 2) = I END IF NEXT SortPointers(0, 1) = 1 FOR I = 1 TO SortCount j = 0 DO WHILE SortPointers(j, 1) <> 0 k = j j = SortPointers(j, 1) LOOP SortPointers(k, 1) = SortPointers(j, 2) SWAP SortData$(I), SortData$(j) SWAP SortPointers(I, 1), SortPointers(j, 1) SWAP SortPointers(I, 2), SortPointers(j, 2) FOR k = 0 TO SortCount FOR l = 1 TO 2 IF SortPointers(k, l) = I THEN SortPointers(k, l) = j NEXT NEXT NEXT END SUB '++++++++++++++++++++++++ SUB zzBasicInt (IntType) STATIC DIM Asm(54) DEF SEG = VARSEG(Asm(0)) IF Asm(1) = 0 THEN Module$ = "BASICINT.OVL" CALL zzInPath(Module$) IF Module$ = "" THEN Module$ = "BASICINT.OVL" ERROR 255 ELSE BLOAD Module$, VARPTR(Asm(0)) END IF END IF CALL Absolute(Regs, IntType, VARPTR(Asm(0))) DEF SEG END SUB SUB zzChangeDir (Directory$) '++++++++++++++++++++++++ DIM Str AS STRING * 65 Str = LTRIM$(RTRIM$(UCASE$(Directory$))) + CHR$(0) IF MID$(Str, 2, 1) = ":" THEN curdrive$ = MID$(Str, 1, 1) Str = MID$(Str, 3) ELSE Regs.AX = &H1900 CALL zzBasicInt(&H21) curdrive$ = CHR$(65 + (Regs.AX AND 255)) END IF IF MID$(Str, 1, 1) = CHR$(0) THEN GOSUB zzChangeDirAA EXIT SUB END IF Str = curdrive$ + ":" + Str Regs.AX = &H3B00 Regs.DS = VARSEG(Str) Regs.DX = VARPTR(Str) CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Directory$ = "" ELSE GOSUB zzChangeDirAA END IF EXIT SUB zzChangeDirAA: Regs.AX = &H4700 Regs.DX = ASC(curdrive$) - 64 Regs.DS = VARSEG(Str) Regs.SI = VARPTR(Str) CALL zzBasicInt(&H21) I = INSTR(Str, CHR$(0)) Directory$ = curdrive$ + ":\" + MID$(Str, 1, I - 1) RETURN END SUB SUB zzChangeDrive (Drive$) '++++++++++++++++++++++++ CALL zzCritOff GOSUB zzChangeDriveProcess CALL zzCritOn EXIT SUB zzChangeDriveProcess: Drive$ = LTRIM$(RTRIM$(UCASE$(Drive$))) IF LEN(Drive$) = 0 THEN Regs.AX = &H1900 CALL zzBasicInt(&H21) Drive$ = CHR$(65 + (Regs.AX AND 255)) + ":" RETURN END IF IF LEN(Drive$) = 1 THEN Drive$ = Drive$ + ":" IF LEN(Drive$) > 2 THEN Drive$ = "?" IF MID$(Drive$, 2, 1) = ":" THEN drv = ASC(Drive$) Drive$ = "?" IF drv < 65 THEN RETURN IF drv > 90 THEN RETURN drv = drv - 65 ' establish whether this is a shared drive Regs.AX = &H440E Regs.BX = drv + 1 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Regs.AX = 0 END IF Regs.AX = Regs.AX AND 255 IF Regs.AX <> 0 THEN IF Regs.AX <> drv + 1 THEN drv = Regs.AX - 1 END IF END IF ' establish whether this is a valid drive Regs.AX = &H1C00 Regs.DX = drv + 1 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN ' now change to it Regs.AX = &HE00 Regs.DX = drv CALL zzBasicInt(&H21) Drive$ = CHR$(65 + drv) + ":" ELSE Drive$ = "?" END IF RETURN END SUB SUB zzCritOff Regs.AX = &H2524 Regs.DS = VARSEG(IRET) Regs.DX = VARPTR(IRET) CALL zzBasicInt(&H21) CritCount = CritCount + 1 END SUB SUB zzCritOn CritCount = CritCount - 1 IF CritCount = 0 THEN Regs.AX = &H2524 Regs.DS = CritSeg Regs.DX = CritPtr CALL zzBasicInt(&H21) END IF END SUB SUB zzFileSelectBox (Pattern$) '++++++++++++++++++++++++ DIM Devices(26) ';valid devices have a non-zero value DIM ValidDevs(27) DIM Parts$(11) ';ten deep is allowed DIM Str AS STRING * 65 CALL zzCritOff GOSUB zzFileSelectBoxProcess CALL zzCritOn EXIT SUB zzFileSelectBoxProcess: ' create the screen IF ScreenDone = 0 THEN BG = 0: FG = 15 CALL zsSetScrnMode(9, 1, 1) FG = 13 CALL ziPublishHere(3, 34, "Select a File", 1, 3) Stuff$ = "(Please Wait)" FG = 14 GOSUB zzFileSelectBoxDD ' print the headers FG = 2 CALL ziPublishHere(41, 17, "Press [F10] for current file information", 0, 1) FG = 8 CALL ziPublishHere(42, 17, "Use left & right arrow keys to change columns", 0, 1) FG = 4 CALL ziPublishHere(43, 17, "Press [F1] to enter a search pattern", 0, 1) END IF ScreenDone = 1 FG = 8: CALL ziPublishHere(8, 2, "Drives", 2, 0): FG = 15 IF NoDriveSelection = 0 THEN Dev = 0: GOSUB zzFileSelectBoxAA ' find the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTASeg = Regs.ES DTAPtr = Regs.BX ' establish the existing devices MaxDevs = 0 FOR I = 1 TO 26 Devices(I) = 0 ValidDevs(I) = 0 Regs.AX = &H440E Regs.BX = I CALL zzBasicInt(&H21) IF (Regs.FL AND 256) = 256 THEN Regs.AX = 0 END IF Regs.AX = Regs.AX AND 255 IF (Regs.AX = 0) OR (Regs.AX = I) THEN Regs.AX = &H1C00 Regs.DX = I CALL zzBasicInt(&H21) IF (Regs.AX AND 255) <> 255 THEN MaxDevs = MaxDevs + 1 Devices(I) = MaxDevs '; set the crossreference ValidDevs(MaxDevs) = I END IF END IF NEXT ' print the valid drives as a list FG = 15 FOR I = 1 TO MaxDevs X$ = CHR$(64 + ValidDevs(I)) CALL ziPublishHere(11 + I, 7, X$, 1, 0) NEXT END IF LINE (GXloc - 16, GYloc + 8)-(GXloc, 319), 0, BF 'clear rest of list NoDriveSelection = 0 FG = 8: CALL ziPublishHere(8, 20, "Tree", 2, 0): FG = 15 ' carve off any 'wildcard' from the specified input parameter Pattern$ = UCASE$(LTRIM$(RTRIM$(Pattern$))) Str = Pattern$ IF INSTR(Str, "?") + INSTR(Str, "*") = 0 THEN Base$ = Pattern$ Wild$ = "*.*" ELSE IF MID$(Str, 2, 1) = ":" THEN Start = 3 ELSE Start = 1 END IF DO I = INSTR(Start, Str, "\") IF I <> 0 THEN Start = I + 1 END IF LOOP UNTIL I = 0 Base$ = MID$(Str, 1, Start - 1) Wild$ = MID$(RTRIM$(Str), Start) END IF CALL zzValidate(Base$) IF Base$ = "?" THEN Base$ = "" CALL zzChangeDir(Base$) END IF IF WhereLeftOff$ <> "" THEN Base$ = WhereLeftOff$: WhereLeftOff$ = "" IF MID$(Base$, LEN(Base$)) = "\" THEN basex$ = MID$(Base$, 1, LEN(Base$) - 1) ELSE basex$ = Base$ END IF ' validate the "wildcard" portion ' (make sure no more than one ".") I = INSTR(Wild$, ".") IF I <> 0 THEN X$ = Wild$ MID$(X$, I, 1) = "+" IF INSTR(X$, ".") THEN Wild$ = "*.*" I = 2 END IF END IF ' (divide it into its two component parts) IF I < 2 THEN wildl$ = Wild$ wildr$ = "" ELSE wildl$ = MID$(Wild$, 1, I - 1) wildr$ = MID$(Wild$, I + 1) END IF IF LEN(wildl$) > 8 OR LEN(wildr$) > 3 THEN Wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF ' (make sure no more than one TRAILING "*" in left part) I = INSTR(wildl$, "*") IF I <> 0 THEN IF I <> LEN(wildl$) THEN Wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF END IF ' (make sure no more than one TRAILING "*" in right part) I = INSTR(wildr$, "*") IF I <> 0 THEN IF I <> LEN(wildr$) THEN Wild$ = "*.*" wildl$ = "*" wildr$ = "*" END IF END IF I = 39 - LEN(Wild$) \ 2 X$ = "[" + Wild$ + "]" CALL ziPublishHere(7, I, X$, 0, 0) ' determine the specified drive Dev = Devices(ASC(Base$) - 64) GOSUB zzFileSelectBoxAA ' create the tree FOR I = 0 TO 11 Parts$(I) = "" NEXT X$ = basex$ + "\" levels = 0 DO I = INSTR(X$, "\") IF I <> 0 THEN Parts$(levels) = MID$(X$, 1, I - 1) levels = levels + 1 X$ = MID$(X$, I + 1) END IF LOOP UNTIL I = 0 Parts$(0) = Parts$(0) + "\" levels = levels - 1 CALL ziPublishHere(12, 15, Parts$(0), 0, 0) IF levels > 0 THEN FOR I = 1 TO levels X$ = SPACE$(I + I) + CHR$(179) CALL ziPublishHere(11 + I + I, 13, X$, 0, 0) X$ = SPACE$(I + I) + CHR$(192) + CHR$(196) + Parts$(I) CALL ziPublishHere(12 + I + I, 13, X$, 0, 0) NEXT END IF oldtree = 255 tree = levels GOSUB zzFileSelectBoxHH ' test for subdirectories present olddline = 0 X$ = basex$ + "\*.*" CALL zzSearchD(X$) IF Directories <> 0 THEN FG = 8: CALL ziPublishHere(8, 64, "Subdirs", 2, 0): FG = 15 FromDir = 1 GOSUB zzFileSelectBoxEE END IF ' test for files present X$ = basex$ + "\" + Wild$ CALL zzSearchF(X$) IF Filenames <> 0 THEN FG = 8: CALL ziPublishHere(8, 51, "Files", 2, 0): FG = 15 FromFile = 1 GOSUB zzFileSelectBoxFF END IF ' determine where to start IF Filenames = 0 THEN IF Directories = 0 THEN FG = 14: CALL ziPublishHere(8, 20, "Tree", 2, 0): FG = 15 Stuff$ = basex$ + "\" GOSUB zzFileSelectBoxDD Column = 2 ELSE FG = 14: CALL ziPublishHere(8, 64, "Subdirs", 2, 0): FG = 15 dline = 1 GOSUB zzFileSelectBoxBB Stuff$ = basex$ + "\" + Directories$(FromDir) GOSUB zzFileSelectBoxDD Column = 4 END IF ELSE FG = 14: CALL ziPublishHere(8, 51, "Files", 2, 0): FG = 15 fline = 1 GOSUB zzFileSelectBoxCC Column = 3 END IF ' determine what to do, based on keystroke DO Stroke$ = "X" DO Stroke$ = INKEY$ LOOP UNTIL LEN(Stroke$) = 0 DO Stroke$ = INKEY$ LOOP WHILE LEN(Stroke$) = 0 IF LEN(Stroke$) = 1 THEN Stroke$ = UCASE$(Stroke$) SELECT CASE ASC(Stroke$) CASE 27 'ESC Pattern$ = "?" NewFile = 0 RETURN CASE 13 'Enter SELECT CASE Column CASE 1 'enactivate new drive X$ = CHR$(ValidDevs(Dev) + 64) + ":" Pattern$ = X$ + "\" + Wild$ LINE (112, 88)-(383, 319), 0, BF 'clear the "tree" area GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess CASE 2 'choose new directory IF tree <> levels THEN Base$ = "" FOR I = 0 TO tree Base$ = Base$ + Parts$(I) IF MID$(Base$, LEN(Base$)) <> "\" THEN Base$ = Base$ + "\" END IF NEXT IF MID$(Base$, LEN(Base$)) <> "\" THEN Base$ = Base$ + "\" END IF Pattern$ = Base$ + Wild$ NoDriveSelection = 1 GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess END IF CASE 3 'exit with chosen filename Pattern$ = Stuff$ WhereLeftOff$ = Base$ RETURN CASE 4 'choose new subdirectory Pattern$ = basex$ + "\" + Directories$(FromDir + dline - 1) Pattern$ = Pattern$ + "\" + Wild$ NoDriveSelection = 1 GOSUB zzFileSelectBoxII GOTO zzFileSelectBoxProcess END SELECT CASE ASC("A") TO ASC("Z") SELECT CASE Column CASE 1 I = ASC(Stroke$) - 64 IF Devices(I) <> 0 THEN Dev = Devices(I) GOSUB zzFileSelectBoxAA END IF CASE 3 I = Filenames X$ = MID$(Filenames$(I), 1, 1) IF X$ >= Stroke$ THEN I = 0 DO I = I + 1 X$ = MID$(Filenames$(I), 1, 1) LOOP WHILE X$ < Stroke$ END IF FromFile = I GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 I = Directories X$ = MID$(Directories$(I), 1, 1) IF X$ >= Stroke$ THEN I = 0 DO I = I + 1 X$ = MID$(Directories$(I), 1, 1) LOOP WHILE X$ < Stroke$ END IF FromDir = I GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT END SELECT ELSE SELECT CASE MID$(Stroke$, 2) CASE "I" 'Page UP SELECT CASE Column CASE 3 OldFromFile = FromFile IF FromFile + fline > 31 THEN FromFile = FromFile + fline - 31 ELSE FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 OldFromDir = FromDir IF FromDir + dline > 31 THEN FromDir = FromDir + dline - 31 ELSE FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "Q" 'Page DN SELECT CASE Column CASE 3 OldFromFile = FromFile IF FromFile + fline + 30 < Filenames THEN FromFile = FromFile + fline + 29 IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC END IF CASE 4 OldFromDir = FromDir IF FromDir + dline + 30 < Directories THEN FromDir = FromDir + dline + 29 IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END IF END SELECT 'CASE "" CASE "G" 'HOME SELECT CASE Column CASE 3 IF FromFile <> 1 THEN FromFile = 1 GOSUB zzFileSelectBoxFF END IF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 IF FromDir <> 1 THEN FromDir = 1 GOSUB zzFileSelectBoxEE END IF dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "O" 'END SELECT CASE Column CASE 3 OldFromFile = FromFile FromFile = Filenames - 29 IF FromFile < 1 THEN FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC CASE 4 OldFromDir = FromDir FromDir = Directories - 29 IF FromDir < 1 THEN FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END SELECT CASE "H" 'UP SELECT CASE Column CASE 1 'drives IF Dev > 1 THEN Dev = Dev - 1 GOSUB zzFileSelectBoxAA END IF CASE 2 'tree IF tree > 0 THEN tree = tree - 1 GOSUB zzFileSelectBoxHH END IF CASE 3 'files I = FromFile + fline - 2 IF I > 0 THEN IF fline > 1 THEN fline = fline - 1 GOSUB zzFileSelectBoxCC ELSE OldFromFile = FromFile FromFile = FromFile - 30 fline = fline + 29 IF FromFile < 1 THEN fline = fline + FromFile - 1 FromFile = 1 END IF IF OldFromFile <> FromFile THEN GOSUB zzFileSelectBoxFF GOSUB zzFileSelectBoxCC END IF END IF CASE 4 'subdirs I = FromDir + dline - 2 IF I > 0 THEN IF dline > 1 THEN dline = dline - 1 GOSUB zzFileSelectBoxBB ELSE OldFromDir = FromDir FromDir = FromDir - 30 dline = dline + 29 IF FromDir < 1 THEN dline = dline + FromDir - 1 FromDir = 1 END IF IF OldFromDir <> FromDir THEN GOSUB zzFileSelectBoxEE GOSUB zzFileSelectBoxBB END IF END IF END SELECT CASE "P" 'DOWN SELECT CASE Column CASE 1 'drives IF Dev < MaxDevs THEN Dev = Dev + 1 GOSUB zzFileSelectBoxAA END IF CASE 2 'tree IF tree < levels THEN tree = tree + 1 GOSUB zzFileSelectBoxHH END IF CASE 3 'files I = FromFile + fline IF I <= Filenames THEN IF fline < 30 THEN fline = fline + 1 GOSUB zzFileSelectBoxCC ELSE FromFile = I: GOSUB zzFileSelectBoxFF fline = 1: GOSUB zzFileSelectBoxCC END IF END IF CASE 4 'subdirs I = FromDir + dline IF I <= Directories THEN IF dline < 30 THEN dline = dline + 1 GOSUB zzFileSelectBoxBB ELSE FromDir = I: GOSUB zzFileSelectBoxEE dline = 1: GOSUB zzFileSelectBoxBB END IF END IF END SELECT CASE "K" 'LEFT SELECT CASE Column CASE 2 'from TREE to DRIVES tree = levels GOSUB zzFileSelectBoxHH FG = 8: CALL ziPublishHere(8, 20, "Tree", 2, 0) FG = 14: CALL ziPublishHere(8, 2, "Drives", 2, 0): FG = 15 'LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B Column = 1 CASE 3 'from FILES to TREE FG = 8: CALL ziPublishHere(8, 51, "Files", 2, 0) FG = 14: CALL ziPublishHere(8, 20, "Tree", 2, 0): FG = 15 Column = 2 CASE 4 'from SUBDIRS to ? dline = 0: GOSUB zzFileSelectBoxBB FG = 8: CALL ziPublishHere(8, 64, "Subdirs", 2, 0): FG = 14 IF Filenames = 0 THEN CALL ziPublishHere(8, 20, "Tree", 2, 0) Column = 2 ELSE CALL ziPublishHere(8, 51, "Files", 2, 0) Column = 3 END IF FG = 15 END SELECT CASE "M" 'RIGHT SELECT CASE Column CASE 1 'from DRIVES to TREE Dev = Devices(ASC(Base$) - 64) GOSUB zzFileSelectBoxAA 'return to original drive FG = 8: CALL ziPublishHere(8, 2, "Drives", 2, 0) 'fg = 15: LINE (10, 7)-(Xmax - 10, Ymax - 7), 4, B FG = 14: CALL ziPublishHere(8, 20, "Tree", 2, 0): FG = 15 Column = 2 CASE 2 'from TREE to ? tree = levels GOSUB zzFileSelectBoxHH IF Filenames = 0 THEN IF Directories <> 0 THEN FG = 8: CALL ziPublishHere(8, 20, "Tree", 2, 0) FG = 14: CALL ziPublishHere(8, 64, "Subdirs", 2, 0): FG = 15 dline = 1: GOSUB zzFileSelectBoxBB Column = 4 END IF ELSE FG = 8: CALL ziPublishHere(8, 20, "Tree", 2, 0) FG = 14: CALL ziPublishHere(8, 51, "Files", 2, 0): FG = 15 Column = 3 END IF CASE 3 'from FILES to SUBDIRS (if possible) IF Directories <> 0 THEN FG = 8: CALL ziPublishHere(8, 51, "Files", 2, 0) FG = 14: CALL ziPublishHere(8, 64, "Subdirs", 2, 0): FG = 15 dline = 1: GOSUB zzFileSelectBoxBB Column = 4 END IF END SELECT CASE ";" LINE (100, 100)-(540, 250), 14, BF LINE (103, 103)-(537, 247), 0, BF CALL ziPublishHere(16, 15, "Enter Filename:", 2, 1) LOCATE 25, 18: PRINT "[............................................]"; LOCATE 25, 19: CALL ziReadField(0, 42, "C*NB.") Exists = 1 ON ERROR GOTO NoFile OPEN Field$ FOR INPUT AS #9 CLOSE 9 ON ERROR GOTO RESUMENEXT IF Field$ <> "" THEN Pattern$ = Field$ IF Exists = 1 THEN RETURN CLS OldDev = 0 ScreenDone = 0 GOTO zzFileSelectBoxProcess CASE "D" WhereLeftOff$ = Base$ Top = MaxTop FOR Left = Middle TO MaxLeft STEP -5 Top = Top - (MaxTop / (Middle - MaxLeft)) LINE (Left, Top)-(640 - Left, 349 - Top), 14, B LINE (Left + 1, Top + 1)-(640 - Left - 1, 349 - Top - 1), 14, B LINE (Left + 2, Top + 2)-(640 - Left - 2, 349 - Top - 2), 0, BF FOR Delay = 0 TO 1000: NEXT Delay NEXT Left OPEN Stuff$ FOR BINARY AS #8 FileSize$ = STR$(LOF(8)) CLOSE 8 FG = 15 CALL ziPublishHere(19, 10, "Filename : ", 1, 0) FG = 9 CALL ziPublishHere(19, 24, Stuff$, 1, 0) FG = 15 CALL ziPublishHere(21, 10, "Size : ", 1, 0) FG = 4 CALL ziPublishHere(21, 23, FileSize$, 1, 0) FG = 15 CALL ziPublishHere(21, 24 + LEN(FileSize$), "Bytes", 1, 0) OPEN Stuff$ FOR RANDOM AS #1 LEN = 256 GET #1, 1, FileHeader CLOSE #1 FileType$ = "Unrecognised or Ascii file" IF LEFT$(FileHeader, 1) = CHR$(233) THEN FileType$ = "Command File (COM)" IF LEFT$(FileHeader, 1) = CHR$(188) THEN FileType$ = "Command File (COM)" IF LEFT$(FileHeader, 2) = "BM" THEN FileType$ = "BitMap (BMP) file" IF LEFT$(FileHeader, 2) = CHR$(10) + CHR$(5) THEN FileType$ = "PaintBrush File (PCX)" IF LEFT$(FileHeader, 2) = CHR$(10) + CHR$(3) THEN FileType$ = "PaintBrush File (PCX)" IF LEFT$(FileHeader, 2) = CHR$(71) + CHR$(73) THEN FileType$ = "Graphic Image File (GIF)" IF LEFT$(FileHeader, 2) = CHR$(215) + CHR$(205) THEN FileType$ = "Windows MetaFile (WMF)" IF LEFT$(FileHeader, 2) = CHR$(49) + CHR$(190) THEN FileType$ = "Windows Write File (WRI)" IF LEFT$(FileHeader, 4) = "RIFF" THEN IF MID$(FileHeader, 9, 4) = "WAVE" THEN FileType$ = "Wave File (WAV)" IF MID$(FileHeader, 9, 4) = "sfbk" THEN FileType$ = "Creative WaveTable Voice File (SBK)" END IF IF LEFT$(FileHeader, 4) = "MThd" THEN FileType$ = "MIDI Sequencer File (MID)" IF LEFT$(FileHeader, 2) = CHR$(67) + CHR$(84) THEN FileType$ = "Compressed MIDI Sequencer File (CMF)" IF LEFT$(FileHeader, 2) = CHR$(67) + CHR$(77) THEN FileType$ = "Creative Pro-Organ File (ORG)" IF LEFT$(FileHeader, 4) = "SBI" + CHR$(&H1A) THEN FileType$ = "Sound Blaster Instrument File (SBI)" IF LEFT$(FileHeader, 4) = "IBK" + CHR$(&H1A) THEN FileType$ = "Sound Blaster Instrument Bank File (IBK)" IF LEFT$(FileHeader, 4) = "CTMF" THEN FileType$ = "Creative Music File (CMF)" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(75) THEN FileType$ = "PK Utilities Compressed File (ZIP)" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(77) THEN FileType$ = "Windows Program Manager Group File (GRP)" IF LEFT$(FileHeader, 2) = CHR$(63) + CHR$(95) THEN FileType$ = "Windows Help Index (GID)" IF LEFT$(FileHeader, 2) = CHR$(0) + CHR$(1) THEN FileType$ = "True Type Font (TTF)" IF LEFT$(FileHeader, 2) = CHR$(76) + CHR$(0) THEN FileType$ = "Windows 95 Link File (LNK)" IF LEFT$(FileHeader, 2) = CHR$(208) + CHR$(207) THEN FileType$ = "Microsoft Word File (DOC)" IF LEFT$(FileHeader, 2) = CHR$(176) + CHR$(77) THEN FileType$ = "Windows 95 Password File (PWL)" IF LEFT$(FileHeader, 2) = CHR$(80) + CHR$(195) THEN FileType$ = "Windows Clipboard Save File (CLP)" IF LEFT$(FileHeader, 2) = CHR$(77) + CHR$(90) THEN IF MID$(FileHeader, 3, 3) = CHR$(144) + CHR$(0) + CHR$(3) THEN FileType$ = "Windows Executable File (EXE, DLL, SCR etc..)" IF MID$(FileHeader, 4, 1) = CHR$(1) THEN FileType$ = "DOS Executable File (EXE, DLL, OVL etc..)" IF MID$(FileHeader, 3, 2) = CHR$(0) + CHR$(0) THEN FileType$ = "Windows Virtual Device Driver (VXD)" END IF IF LEFT$(FileHeader, 5) = CHR$(0) + CHR$(0) + CHR$(0) + CHR$(72) + CHR$(0) THEN FileType$ = "Cubasis Music File (ALL)" IF LEFT$(FileHeader, 20) = "SuperCalc ver. 1.10" THEN FileType$ = "SuperCalc SpreadSheet (CAL)" IF LEFT$(FileHeader, 2) = CHR$(0) + CHR$(120) THEN FileType$ = "Windows Program Information File (PIF)" IF FLIHeader.ID = &HAF11 THEN FileType$ = "AutoDesk Animator Flic File (FLI)" IF FLIHeader.ID = &HAF12 THEN FileType$ = "AutoDesk Animator Flic File (FLI)" IF LEFT$(FileHeader, 19) = "Creative Voice File" THEN FileType$ = "Creative Voice File (VOC)" IF (ASC(LEFT$(FileHeader, 1)) AND (7)) = 3 THEN FileType$ = "dBase DataBase File (DBF)" PRINT FileHeader FG = 15 CALL ziPublishHere(23, 10, "File Type : ", 1, 0) FG = 2 CALL ziPublishHere(23, 24, FileType$, 1, 0) SLEEP CLS OldDev = 0 ScreenDone = 0 GOTO zzFileSelectBoxProcess CASE ELSE LOCATE 1, 1 PRINT Stroke$ END SELECT END IF LOOP ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º AA ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ change the cursor bar on "dev" ³ ' ³ ³ ' ³ input: dev output: olddev ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxAA: IF Dev <> OldDev THEN FromRow = 11 + OldDev ToRow = FromRow FromCol = 5 ToCol = 10 swap1 = 0: swap2 = 15 IF OldDev > 0 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 11 + Dev ToRow = FromRow OldDev = Dev IF OldDev > 0 THEN GOSUB zzFileSelectBoxGG END IF END IF RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º BB ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ change the cursor bar on "dline" ³ ' ³ ³ ' ³ input: dline output: olddline ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxBB: IF dline <> olddline THEN FromRow = 10 + olddline ToRow = FromRow FromCol = 67 ToCol = 78 swap1 = 0: swap2 = 15 IF olddline > 0 THEN GOSUB zzFileSelectBoxGG FromRow = 10 + dline ToRow = FromRow olddline = dline IF dline > 0 THEN GOSUB zzFileSelectBoxGG END IF RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º CC ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ change the cursor bar on "fline" ³ ' ³ ³ ' ³ input: fline output: oldfline ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxCC: IF fline <> oldfline THEN FromRow = 10 + oldfline ToRow = FromRow FromCol = 51 ToCol = 62 hh$ = Filenames$(FromFile + oldfline - 1) swap1 = 15: swap2 = 0 IF RIGHT$(hh$, 3) = "GIF" THEN swap1 = 9: swap2 = 0 IF RIGHT$(hh$, 3) = "PCX" THEN swap1 = 14: swap2 = 0 IF RIGHT$(hh$, 3) = "WAV" THEN swap1 = 12: swap2 = 0 IF RIGHT$(hh$, 3) = "MID" THEN swap1 = 10: swap2 = 0 IF RIGHT$(hh$, 3) = "FLI" THEN swap1 = 13: swap2 = 0 IF RIGHT$(hh$, 3) = "BMP" THEN swap1 = 11: swap2 = 0 IF RIGHT$(hh$, 3) = "DBF" THEN swap1 = 6: swap2 = 0 IF oldfline > 0 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 10 + fline ToRow = FromRow oldfline = fline hh$ = Filenames$(FromFile + fline - 1) swap1 = 15: swap2 = 0 IF RIGHT$(hh$, 3) = "GIF" THEN swap1 = 9: swap2 = 0 IF RIGHT$(hh$, 3) = "PCX" THEN swap1 = 14: swap2 = 0 IF RIGHT$(hh$, 3) = "WAV" THEN swap1 = 12: swap2 = 0 IF RIGHT$(hh$, 3) = "MID" THEN swap1 = 10: swap2 = 0 IF RIGHT$(hh$, 3) = "FLI" THEN swap1 = 13: swap2 = 0 IF RIGHT$(hh$, 3) = "BMP" THEN swap1 = 11: swap2 = 0 IF RIGHT$(hh$, 3) = "DBF" THEN swap1 = 6: swap2 = 0 GOSUB zzFileSelectBoxGG Stuff$ = basex$ + "\" + Filenames$(FromFile + fline - 1) GOSUB zzFileSelectBoxDD END IF RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º DD ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ Determine middle of line for publishing "Stuff$" ³ ' ³ ³ ' ³ ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxDD: LINE (38, 26)-(601, 46), 3, BF LINE (38, 26)-(601, 46), 8, B CALL ziPublishHere(5, 40 - LEN(Stuff$) \ 2, Stuff$, 1, 2) RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º EE ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ Show 30 subdirectories ³ ' ³ ³ ' ³ input: FromDir ³ ' ³ ³ ' ³ ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxEE: LINE (512, 80)-(XMax - 11, 319), 0, BF IF FromDir > Directories THEN RETURN IF FromDir > 1 THEN FG = 4: CALL ziPublishHere(11, 65, CHR$(24), 0, 0): FG = 15 END IF IF FromDir + 30 <= Directories THEN FG = 4: CALL ziPublishHere(40, 65, CHR$(25), 0, 0): FG = 15 j = FromDir + 29 ELSE j = Directories END IF FOR I = FromDir TO j k = INSTR(Directories$(I), ".") IF k = 0 THEN X$ = Directories$(I) ELSE X$ = MID$(Directories$(I), 1, k - 1) + SPACE$(8) X$ = MID$(X$, 1, 9) + MID$(Directories$(I), k + 1) END IF CALL ziPublishHere(11 + I - FromDir, 67, X$, 0, 1) NEXT olddline = 0 RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º FF ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ Show 30 filenames ³ ' ³ ³ ' ³ input: FromFile ³ ' ³ ³ ' ³ ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxFF: LINE (384, 80)-(495, 319), 0, BF IF FromFile > Filenames THEN RETURN IF FromFile > 1 THEN FG = 4: CALL ziPublishHere(11, 49, CHR$(24), 0, 0): FG = 15 END IF IF FromFile + 30 <= Filenames THEN FG = 4: CALL ziPublishHere(40, 49, CHR$(25), 0, 0): FG = 15 j = FromFile + 29 ELSE j = Filenames END IF FOR I = FromFile TO j k = INSTR(Filenames$(I), ".") IF k = 0 THEN X$ = Filenames$(I) ELSE X$ = MID$(Filenames$(I), 1, k - 1) + SPACE$(8) X$ = MID$(X$, 1, 9) + MID$(Filenames$(I), k + 1) FG = 15 IF RIGHT$(X$, 3) = "GIF" THEN FG = 9 IF RIGHT$(X$, 3) = "PCX" THEN FG = 14 IF RIGHT$(X$, 3) = "WAV" THEN FG = 12 IF RIGHT$(X$, 3) = "MID" THEN FG = 10 IF RIGHT$(X$, 3) = "FLI" THEN FG = 13 IF RIGHT$(X$, 3) = "BMP" THEN FG = 11 IF RIGHT$(X$, 3) = "DBF" THEN FG = 6 END IF CALL ziPublishHere(11 + I - FromFile, 51, X$, 0, 0) NEXT oldfline = 0 RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º GG ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ Swap the colours (swap1 and swap2) of a region ³ ' ³ ³ ' ³ input: FromCol, FromRow, ToCol, ToRow, swap1, swap2 ³ ' ³ ³ ' ³ ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxGG: fx = FromCol * 8 - 8 fy = FromRow * 8 - 8 tx = ToCol * 8 - 1 ty = ToRow * 8 - 1 FOR ix = fx TO tx FOR iy = fy TO ty SELECT CASE POINT(ix, iy) CASE swap1 PSET (ix, iy), swap2 CASE swap2 PSET (ix, iy), swap1 END SELECT NEXT NEXT RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º HH ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ change the cursor bar on "tree" ³ ' ³ ³ ' ³ input: tree output: oldtree ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxHH: IF tree <> oldtree THEN FromRow = 12 + oldtree + oldtree ToRow = FromRow FromCol = 15 + oldtree + oldtree ToCol = FromCol + 11 swap1 = 0: swap2 = 15 IF oldtree <> 255 THEN GOSUB zzFileSelectBoxGG END IF FromRow = 12 + tree + tree ToRow = FromRow FromCol = 15 + tree + tree ToCol = FromCol + 11 oldtree = tree GOSUB zzFileSelectBoxGG END IF RETURN ' ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ' º II ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ' ÈÑÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ ³ ' ³ clear screen areas when changing directory ³ ' ³ ³ ' ³ ³ ' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ zzFileSelectBoxII: oldtree = 255 oldfline = 0 olddline = 0 LINE (112, 16 * tree + 80)-(383, 319), 0, BF LINE (384, 56)-(495, 319), 0, BF LINE (504, 56)-(XMax - 11, 319), 0, BF Stuff$ = "(Please Wait)" FG = 14: GOSUB zzFileSelectBoxDD: FG = 15 RETURN END SUB '++++++++++++++++++++++++ SUB zzInPath (Field$) X$ = ".;" + ENVIRON$("PATH") IF RIGHT$(X$, 1) <> ";" THEN X$ = X$ + ";" I = 1 DO j = INSTR(I, X$, ";") IF j THEN Y$ = UCASE$(MID$(X$, I, j - I)) I = j + 1 IF RIGHT$(Y$, 1) <> "\" THEN Y$ = Y$ + "\" F$ = Y$ + Field$ Bad = 0 OPEN "I", 1, F$ IF Bad = 0 THEN CLOSE 1 EXIT DO END IF F$ = "" END IF LOOP WHILE j Bad = 0 Field$ = F$ END SUB SUB zzSearchD (Pattern$) '++++++++++++++++++++++++ DIM Str AS STRING * 65 CALL zzCritOff GOSUB zzSearchDProcess CALL zzCritOn EXIT SUB zzSearchDProcess: UpperBound = UBOUND(Directories$) Str = LTRIM$(RTRIM$(UCASE$(Pattern$))) Pattern$ = "?" ' clear the Directories$ array FOR I = 1 TO 500 Directories$(I) = "" NEXT Directories = 0 ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTASeg = Regs.ES DTAPtr = Regs.BX ' confirm that the drive (if specified) is valid IF MID$(Str, 2, 1) = ":" THEN I = ASC(Str) IF I < 65 THEN RETURN IF I > 90 THEN RETURN Regs.AX = &H440E Regs.BX = I - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> I - 64) THEN I = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = I - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF X$ = RTRIM$(Str) IF (X$ = "") OR (MID$(X$, 2) = ":") THEN X$ = X$ + "*.*" END IF IF (MID$(X$, LEN(X$)) = "\") THEN X$ = X$ + "*.*" END IF IF INSTR(X$, "*") + INSTR(X$, "?") = 0 THEN X$ = X$ + "\*.*" END IF ' initiate the search Pattern$ = X$ Str = X$ + CHR$(0) Regs.AX = &H4E00 Regs.CX = &H10 Regs.DS = VARSEG(Str) Regs.DX = VARPTR(Str) CALL zzBasicInt(&H21) DO WHILE (Regs.FL AND 256) = 0 DEF SEG = DTASeg ' pull the name (letter by letter) from the DTA IF (PEEK(DTAPtr + &H15) AND &H10) = &H10 THEN Name$ = "" I = &H1E DO j = PEEK(DTAPtr + I) IF j <> 0 THEN Name$ = Name$ + CHR$(j) END IF I = I + 1 LOOP UNTIL j = 0 ' omit "." and ".." IF MID$(Name$, 1, 1) <> "." THEN Directories = Directories + 1 IF Directories > UpperBound THEN RETURN Directories$(Directories) = Name$ END IF END IF ' keep going until all matches are found Regs.AX = &H4F00 CALL zzBasicInt(&H21) LOOP ' now find the first byte of the directory pattern itself IF MID$(Str, 2, 1) = ":" THEN Start = 3 ELSE Start = 1 END IF DO I = INSTR(Start, Str, "\") IF I <> 0 THEN Start = I + 1 END IF LOOP UNTIL I = 0 X$ = MID$(Str, 1, Start - 1) CALL zzValidate(X$) IF MID$(X$, LEN(X$)) <> "\" THEN X$ = X$ + "\" I = INSTR(Str, CHR$(0)) Pattern$ = RTRIM$(X$ + MID$(Str, Start, I - Start)) IF Directories <> 0 THEN SortCount = Directories CALL zzAlphaSort(Directories$()) END IF RETURN END SUB SUB zzSearchF (Pattern$) '++++++++++++++++++++++++ DIM Str AS STRING * 65 CALL zzCritOff GOSUB zzSearchFProcess CALL zzCritOn EXIT SUB zzSearchFProcess: UpperBound = UBOUND(Filenames$) Str = LTRIM$(RTRIM$(UCASE$(Pattern$))) Pattern$ = "?" ' clear the FileNames$ array FOR I = 1 TO 1000 Filenames$(I) = "" NEXT Filenames = 0 ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTASeg = Regs.ES DTAPtr = Regs.BX ' confirm that the drive (if specified) is valid IF MID$(Str, 2, 1) = ":" THEN I = ASC(Str) IF I < 65 THEN RETURN IF I > 90 THEN RETURN Regs.AX = &H440E Regs.BX = I - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> I - 64) THEN I = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = I - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF X$ = RTRIM$(Str) IF (X$ = "") OR (MID$(X$, 2) = ":") THEN X$ = X$ + "*.*" END IF IF (MID$(X$, LEN(X$)) = "\") THEN X$ = X$ + "*.*" END IF IF INSTR(X$, "*") + INSTR(X$, "?") = 0 THEN X$ = X$ + "\*.*" END IF ' initiate the search Pattern$ = X$ Str = X$ + CHR$(0) Regs.AX = &H4E00 Regs.CX = &H27 Regs.DS = VARSEG(Str) Regs.DX = VARPTR(Str) CALL zzBasicInt(&H21) DO WHILE (Regs.FL AND 256) = 0 DEF SEG = DTASeg ' pull the name (letter by letter) from the DTA Name$ = "" I = &H1E DO j = PEEK(DTAPtr + I) IF j <> 0 THEN Name$ = Name$ + CHR$(j) END IF I = I + 1 LOOP UNTIL j = 0 Filenames = Filenames + 1 IF Filenames > UpperBound THEN RETURN Filenames$(Filenames) = Name$ Regs.AX = &H4F00 CALL zzBasicInt(&H21) LOOP ' now find the first byte of the file pattern itself IF MID$(Str, 2, 1) = ":" THEN Start = 3 ELSE Start = 1 END IF DO I = INSTR(Start, Str, "\") IF I <> 0 THEN Start = I + 1 END IF LOOP UNTIL I = 0 X$ = MID$(Str, 1, Start - 1) CALL zzValidate(X$) IF MID$(X$, LEN(X$)) <> "\" THEN X$ = X$ + "\" I = INSTR(Str, CHR$(0)) Pattern$ = RTRIM$(X$ + MID$(Str, Start, I - Start)) IF Filenames <> 0 THEN SortCount = Filenames CALL zzAlphaSort(Filenames$()) END IF RETURN END SUB SUB zzValidate (Directory$) '++++++++++++++++++++++++ DIM Str AS STRING * 65 CALL zzCritOff GOSUB zzValidateProcess CALL zzCritOn EXIT SUB zzValidateProcess: CandPath$ = LTRIM$(RTRIM$(UCASE$(Directory$))) IF MID$(CandPath$, LEN(CandPath$)) = "\" THEN IF LEN(CandPath$) > 1 THEN IF MID$(CandPath$, 2) <> ":\" THEN CandPath$ = MID$(CandPath$, 1, LEN(CandPath$) - 1) END IF END IF END IF Directory$ = "?" ' check that any named drive is valid IF MID$(CandPath$, 2, 1) = ":" THEN I = ASC(MID$(CandPath$, 1, 1)) IF I < 65 THEN RETURN IF I > 90 THEN RETURN Regs.AX = &H440E Regs.BX = I - 64 CALL zzBasicInt(&H21) IF (Regs.FL AND 256) <> 256 THEN j = Regs.AX AND 255 IF (j <> 0) AND (j <> I - 64) THEN I = j + 64 END IF END IF Regs.AX = &H1C00 Regs.DX = I - 64 CALL zzBasicInt(&H21) IF (Regs.AX AND 255) = 255 THEN RETURN END IF ' handle special case of root directory IF CandPath$ = "\" THEN Directory$ = "" CALL zzChangeDrive(Directory$) Directory$ = Directory$ + "\" RETURN END IF IF MID$(CandPath$, 2) = ":\" THEN Directory$ = CandPath$ RETURN END IF ' handle special case of NO directory IF CandPath$ = "" THEN CALL zzChangeDir(CandPath$) Directory$ = CandPath$ RETURN END IF IF MID$(CandPath$, 2) = ":" THEN Regs.AX = &H4700 Regs.DX = ASC(MID$(CandPath$, 1, 1)) - 64 Regs.DS = VARSEG(Str) Regs.SI = VARPTR(Str) CALL zzBasicInt(&H21) I = INSTR(Str, CHR$(0)) Directory$ = CandPath$ + "\" + MID$(Str, 1, I - 1) RETURN END IF Str = CandPath$ + CHR$(0) IF INSTR(Str, "*") + INSTR(Str, "?") > 0 THEN RETURN ' initiate the search Regs.AX = &H4E00 Regs.CX = &H10 Regs.DS = VARSEG(Str) Regs.DX = VARPTR(Str) CALL zzBasicInt(&H21) ' abandon if not a valid directory IF (Regs.FL AND 256) <> 0 THEN RETURN ' locate the DTA Regs.AX = &H2F00 CALL zzBasicInt(&H21) DTASeg = Regs.ES DTAPtr = Regs.BX DEF SEG = DTASeg attr = PEEK(DTAPtr + &H15) IF (attr AND &H10) = 0 THEN RETURN ' establish the status quo so that we can change back olddrv$ = "" CALL zzChangeDrive(olddrv$) IF MID$(Str, 2, 1) = ":" THEN newdrv$ = MID$(Str, 1, 2) ELSE newdrv$ = olddrv$ END IF CALL zzChangeDrive(newdrv$) 'change to new drive olddir$ = "" CALL zzChangeDir(olddir$) 'find the current directory on new drive CALL zzChangeDir(Str) 'change to the desired directory CALL zzChangeDir(olddir$) 'change back to the current directory CALL zzChangeDrive(olddrv$) 'change back to old drive IF Root = 0 THEN Directory$ = RTRIM$(Str) ELSE Directory$ = MID$(Str, 1, 2) + "\" END IF RETURN END SUB