'=========================================================================== ' Subject: CATALOG BASIC FILES Date: 05-23-93 (00:00) ' Author: John Gallas Code: QB, PDS ' Origin: harryst@castel.nl Packet: MISC.ABC '=========================================================================== ' CATALOG.BAS - By John Gallas - Completed on 5/23/1993 ' ' You can do whatever you want with this program, but please remember who ' really wrote it. ' ' Its a directory catalogger! I use it for keeping track of all my ' QB/PDS/PB/etc source code. I have a directory devoted to source, ' and whenever I get a new file, I just zip it up and copy it into the ' directory. Then once in awhile, I go into the program and [S]can ' for new files, and it locates all the files that aren't in the database ' that are in the directory, I type in descriptions, and they're added. ' Then I S[o]rt the database using an extremely fast shell sort. I can ' easily go through all my files and search for certian ones that I want, ' and I can change any of the descriptions with the touch of a button. ' This could be a nice basis for a file system for a BBS if anyone wanted ' to expand on it. DEFINT A-Z DECLARE SUB Scroll (Direction%, Top%, Left%, Bottom%, Right%, Lines%, Attr%) DECLARE SUB RemoveRecords () DECLARE SUB FastSortI (Inarray() AS ANY, Lower AS INTEGER, Upper AS INTEGER) DECLARE SUB FindFiles () DECLARE SUB ScanForNew () DECLARE SUB ScrollDN () DECLARE SUB ScrollUP () DECLARE SUB ExtractFile () DECLARE SUB Sort () DECLARE SUB SpecifyNewRecords () DECLARE SUB UpdateRecords () DECLARE FUNCTION AllFiles$ () DECLARE FUNCTION EditString$ (Text$, MaxX%) DECLARE FUNCTION TruncateFile% (Handle%, NewLength&) DECLARE FUNCTION Choice$ (Choices$) DECLARE FUNCTION DIR$ (Path$) DECLARE FUNCTION GetSize& (file$) DECLARE FUNCTION Match% (Filename$, WildCard$) DECLARE FUNCTION YesNo$ () '----- Some constants that DIR$ uses CONST DOS = &H21 CONST SetDTA = &H1A00, FindFirst = &H4E00, FindNext = &H4F00 'used for the scrolling routines CONST sUP = &H600, sDOWN = &H700 CONST True = -1, False = 0 ' Don't forget to load QB.QLB/QBX.QLB! ' $INCLUDE: '\QB45\QB.BI' TYPE CatalogType Filename AS STRING * 12 FileSize AS LONG Description AS STRING * 60 END TYPE DIM SHARED Filename$ 'the catalog file name DIM SHARED Cat AS CatalogType CLS IF COMMAND$ = "" THEN PRINT "Data file: "; Filename$ = "" Filename$ = EditString$(Filename$, 40) IF Filename$ = "" THEN END ELSE Filename$ = COMMAND$ END IF OPEN Filename$ FOR RANDOM AS #1 LEN = LEN(Cat) 'turn off the blinking cursor LOCATE , , 0, 12, 13 'prepare the screen CLS LOCATE 4, 1 PRINT STRING$(80, 196); LOCATE 25, 1 PRINT STRING$(80, 196); GOSUB PrintHelp Total = LOF(1) \ LEN(Cat) Down = 5 StartLine = 1 GOSUB PrintPage Selected = 1 Down = 5 LOCATE , , 0 DO x$ = "[" + LTRIM$(STR$(Selected)) + "/" + LTRIM$(STR$(Total)) + "]" LOCATE 3, 75 - LEN(x$) PRINT SPACE$(5) + x$; LOCATE Down, 13 PRINT CHR$(17); DO x$ = INKEY$ LOOP UNTIL LEN(x$) LOCATE Down, 13 PRINT " "; SELECT CASE x$ CASE CHR$(0) + CHR$(72) 'up key IF Selected > 1 THEN Selected = Selected - 1 Down = Down - 1 IF Down = 4 THEN ScrollDN Down = 5 GET #1, Selected, Cat LOCATE Down, 1 GOSUB PrintLine END IF END IF CASE CHR$(0) + CHR$(80) 'down key IF Selected < Total THEN Selected = Selected + 1 Down = Down + 1 IF Down = 25 THEN ScrollUP Down = 24 GET #1, Selected, Cat LOCATE Down, 1 GOSUB PrintLine END IF END IF CASE CHR$(0) + CHR$(73) 'page up IF Selected - 20 < Down - 4 THEN Selected = Down - 4 ELSE Selected = Selected - 20 END IF 'find out which record # is at the top of the screen StartLine = Selected - (Down - 5) GOSUB PrintPage CASE CHR$(0) + CHR$(81) 'page down StartLine = Selected - (Down - 5) 'if we're not on the last page then.. IF Total - StartLine > 19 THEN Selected = Selected + 20 IF Selected > Total THEN Down = Down - (Selected - Total) Selected = Total END IF StartLine = Selected - (Down - 5) GOSUB PrintPage END IF CASE CHR$(0) + CHR$(71) 'home Selected = 1 Down = 5 StartLine = Selected - (Down - 5) GOSUB PrintPage CASE CHR$(0) + CHR$(79) 'end IF Total < 20 THEN Selected = Total Down = 5 + Selected StartLine = 1 ELSE StartLine = Total - 19 Selected = Total Down = 24 END IF GOSUB PrintPage CASE CHR$(13) 'return, edit the description field GET #1, Selected, Cat Temp$ = RTRIM$(Cat.Description) LOCATE Down, 20 PRINT ">"; Temp$ = EditString$(Temp$, 60) '60 is the maximum length allowed. 'Now fill in what they wrote. If they wrote something different from 'the origional, but then aborted it, editstring$ will return the 'unchanged string. LOCATE Down, 20, 0 PRINT " "; Cat.Description = Temp$ PUT #1, Selected, Cat LOCATE Down, 1 GOSUB PrintLine Temp$ = "" CASE CHR$(27), "Q", "q" EXIT DO CASE "R", "r" 'remove files RemoveRecords GOSUB PrintHelp Total = LOF(1) \ LEN(Cat) IF Selected > Total THEN Selected = Selected - 1 Down = Down - 1 IF Down = 4 THEN ScrollDN Down = 5 GET #1, Selected, Cat LOCATE Down, 1 GOSUB PrintLine END IF END IF StartLine = Selected - (Down - 5) GOSUB PrintPage CASE "S", "s" 'scan for new files in the directory ScanForNew LOCATE , , 0 StartLine = Selected - (Down - 5) GOSUB PrintPage GOSUB PrintHelp CASE "F", "f", "\" 'look for files, the \ is for LIST users .. :-) FindFiles LOCATE , , 0 StartLine = Selected - (Down - 5) GOSUB PrintPage GOSUB PrintHelp CASE "O", "o" 'sort records Sort GOSUB PrintPage GOSUB PrintHelp CASE "U", "u" 'update records UpdateRecords GOSUB PrintPage GOSUB PrintHelp END SELECT LOOP LOCATE 25, 1: PRINT SPACE$(80); LOCATE 24, 1 END PrintLine: PRINT USING "\ \ ###### \ \"; Cat.Filename; Cat.FileSize; Cat.Description; RETURN PrintPage: Dn = 5 FOR x = StartLine TO Total GET #1, x, Cat LOCATE Dn, 1 PRINT USING "\ \ ###### \ \"; Cat.Filename; Cat.FileSize; Cat.Description; Dn = Dn + 1 IF Dn = 25 THEN EXIT FOR NEXT x IF Dn < 25 THEN 'fill the rest with blanks FOR x = Dn TO 24 LOCATE x, 1 PRINT SPACE$(80); NEXT x END IF RETURN PrintHelp: LOCATE 1, 1 PRINT "[Catalog 1.0 By John Gallas] [S]can for new files [F]ind file(s) " PRINT " [R]emove files [U]pdate records " PRINT " Filename Size Description S[o]rt database [Q]uit " RETURN FUNCTION AllFiles$ ' Returns a string of all the files in our database, seperated by plus's. ' This is used with INSTR to check for new files. Temp$ = "" x = LOF(1) \ LEN(Cat) 'find the total # of records FOR I = 1 TO x GET #1, I, Cat Temp$ = Temp$ + "+" + RTRIM$(Cat.Filename) NEXT I IF LEN(Temp$) THEN Temp$ = Temp$ + "+" AllFiles$ = Temp$ END FUNCTION FUNCTION Choice$ (Choices$) DO B$ = INKEY$ B$ = LCASE$(B$) IF LEN(B$) THEN IF INSTR(LCASE$(Choices$), B$) THEN EXIT DO END IF LOOP Choice$ = B$ END FUNCTION FUNCTION DIR$ (FileSpec$) STATIC ' this function was written by Dave Cleary DIM DTA AS STRING * 44, Regs AS RegTypeX Null$ = CHR$(0) '----- Set up our own DTA so we don't destroy COMMAND$ Regs.ax = SetDTA 'Set DTA function Regs.dx = VARPTR(DTA) 'DS:DX points to our DTA Regs.ds = -1 'Use current value for DS INTERRUPTX DOS, Regs, Regs 'Do the interrupt '----- Check to see if this is First or Next IF LEN(FileSpec$) THEN 'FileSpec$ isn't null, so 'FindFirst FileSpecZ$ = FileSpec$ + Null$ 'Make FileSpec$ into an ASCIIZ 'string Regs.ax = FindFirst 'Perform a FindFirst Regs.cx = 0 'Only look for normal files Regs.dx = SADD(FileSpecZ$) 'DS:DX points to ASCIIZ file Regs.ds = -1 'Use current DS ELSE 'We have a null FileSpec$, Regs.ax = FindNext 'so FindNext END IF INTERRUPTX DOS, Regs, Regs 'Do the interrupt '----- Return file name or null IF Regs.flags AND 1 THEN 'No files found DIR$ = "" 'Return null string ELSE Null = INSTR(31, DTA, Null$) 'Get the filename found DIR$ = MID$(DTA, 31, Null - 30) 'It's an ASCIIZ string starting END IF 'at offset 30 of the DTA END FUNCTION FUNCTION EditString$ (Text$, MaxX) ' heres my cheap little string editor OldText$ = Text$ 'incase they want to abort later Down = CSRLIN across = POS(0) OrgAc = across in = LEN(Text$) + 1 IF in > 1 THEN across = across + in - 1 FT = True ' first time through flag DO LOCATE Down, OrgAc PRINT Text$ + STRING$(MaxX - LEN(Text$), 32); IF InsOn THEN IF across <= 80 THEN LOCATE Down, across, 1, 1, 30 ELSE LOCATE Down, 80, 1, 1, 30 END IF ELSE IF across <= 80 THEN LOCATE Down, across, 1, 12, 30 ELSE LOCATE Down, 80, 1, 12, 30 END IF END IF DO x$ = INKEY$ IF LEN(x$) THEN IF ASC(x$) < 32 THEN IF x$ <> CHR$(8) AND x$ <> CHR$(9) AND x$ <> CHR$(13) AND x$ <> CHR$(27) AND LEN(x$) = 1 THEN x$ = "" END IF END IF LOOP UNTIL LEN(x$) IF LEN(x$) = 2 THEN SELECT CASE x$ CASE CHR$(0) + CHR$(77) 'right FT = False IF in < MaxX AND in <= LEN(Text$) THEN across = across + 1 in = in + 1 END IF CASE CHR$(0) + CHR$(75) 'left FT = False IF in > 1 THEN in = in - 1 across = across - 1 END IF CASE CHR$(0) + CHR$(83) 'del Text$ = LEFT$(Text$, in - 1) + MID$(Text$, in + 1) FT = False CASE CHR$(0) + CHR$(82) 'insrt FT = False InsOn = (InsOn = False) CASE CHR$(0) + CHR$(71) 'home FT = False in = 1 across = OrgAc CASE CHR$(0) + CHR$(79) 'end FT = False n = LEN(Text$) + 1 d = n - in in = n across = across + d CASE ELSE END SELECT ELSE SELECT CASE x$ CASE CHR$(8) IF in > 1 THEN FT = False Text$ = LEFT$(Text$, in - 2) + MID$(Text$, in) across = across - 1 in = in - 1 END IF CASE CHR$(27) EditString$ = OldText$ 'restore it EXIT FUNCTION CASE CHR$(13) LOCATE , , 1, 12, 13 EditString$ = Text$ EXIT FUNCTION CASE ELSE IF FT = True THEN Text$ = "" across = OrgAc in = 1 FT = False END IF IF in <= MaxX THEN IF FT = True THEN Text$ = "" IF LEN(Text$) < in THEN Text$ = Text$ + SPACE$(in - LEN(Text$)) IF InsOn THEN IF LEN(Text$) < MaxX THEN Text$ = LEFT$(Text$, in - 1) + x$ + MID$(Text$, in) in = in + 1 across = across + 1 END IF ELSE MID$(Text$, in) = x$ in = in + 1 across = across + 1 END IF END IF END SELECT END IF LOOP END FUNCTION SUB FastSortI (Inarray() AS CatalogType, Lower AS INTEGER, Upper AS INTEGER) ' This routine was writen by Ryan Wellman. ' Copyright 1992, Ryan Wellman, all rights reserved. ' Released as Freeware October 22, 1992. ' You may freely use, copy & modify this code as you see ' fit. Under the condition that I am given credit for ' the original sort routine, and partial credit for modifided ' versions of the routine. ' vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv ' ' Ok, heres your partial credit Ryan. I changed it to ' specifically sort my Catalog array by Filename. ' ' ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Increment = (Upper + Lower) L2 = Lower - 1 DO ' The Increment variable is used to check how far apart the ' program will check. Also cut the size of increment in half ' to decrese Increment which makes the sorted array more ' accurate. Increment = Increment \ 2 I2 = Increment + L2 ' Step through the array 1 element at a time and compare the ' elements 'Increment' entries away. FOR Index = Lower TO Upper - Increment IF Inarray(Index).Filename > Inarray(Index + Increment).Filename THEN SWAP Inarray(Index), Inarray(Index + Increment) ' If the the current pointer for Index is greater ' than Increment then step back by increment - 1 ' so that the variable can be put as close as it ' can get to it's final point. IF Index > I2 THEN ' Store a pointer to the curent position so ' that it can be restored when this entry is ' in it's place. Causes it to run over 10 ' times faster on large random arrays. If ' CutPoint has a value then set a new one. CutPoint = Index StopNow = 0 DO Index = Index - Increment IF Inarray(Index).Filename > Inarray(Index + Increment).Filename THEN SWAP Inarray(Index), Inarray(Index + Increment) ' Reduce the array pointer so that you can slide ' the current number almost to it's finished ' position. ELSE StopNow = -1 Index = CutPoint END IF LOOP UNTIL StopNow ' Reduce the array pointer so that you can slide ' the current number almost to it's finished ' position. END IF END IF NEXT Index LOOP UNTIL Increment <= 1 END SUB SUB FindFiles ' Used in searching for a certian file SHARED Selected, Down, Total SHARED DescPattern$, WildCard$ FOR x = 1 TO 3 LOCATE x, 1 PRINT SPACE$(80); NEXT x LOCATE 1, 1, 1, 12, 13 PRINT "Search for Filename or Description? "; x$ = Choice$("FDQ" + CHR$(27)) IF x$ = "q" OR x$ = CHR$(27) THEN EXIT SUB LOCATE 1, 1 PRINT SPACE$(80) IF x$ = "f" THEN GOTO FilenameSearch LOCATE 1, 1 PRINT "[Description Search]" PRINT "Search pattern: "; x$ = DescPattern$ DescPattern$ = EditString$(DescPattern$, 60) IF LEN(DescPattern$) = 0 THEN EXIT SUB PRINT PRINT "Searching.."; FOR x = Selected + 1 TO Total GET #1, x, Cat IF INSTR(RTRIM$(UCASE$(Cat.Description)), UCASE$(DescPattern$)) THEN 'found it Selected = x Down = 5 LOCATE , , 0 EXIT SUB END IF NEXT x LOCATE 3, 1 PRINT SPACE$(80); LOCATE 3, 1 PRINT "Not found. Press a key.."; x$ = INPUT$(1) EXIT SUB FilenameSearch: LOCATE 1, 1 PRINT "[Filename Search]" PRINT "Enter filename to search for (WildCards are allowed)" PRINT ":"; WildCard$ = EditString$(WildCard$, 12) IF WildCard$ = "" THEN EXIT SUB WildCard$ = UCASE$(WildCard$) 'look for it from this point LOCATE 2, 1: PRINT SPACE$(160); LOCATE 2, 1 PRINT "Searching for: " + WildCard$ FOR x = Selected + 1 TO Total GET #1, x, Cat Temp$ = RTRIM$(Cat.Filename) IF Match(Temp$, WildCard$) THEN 'found a match Selected = x Down = 5 EXIT SUB END IF NEXT x 'didn't find any LOCATE 2, 1 PRINT "File not found." + SPACE$(12) PRINT "Press a key.."; x$ = INPUT$(1) END SUB FUNCTION GetSize& (file$) 'returns the size of a file OPEN file$ FOR BINARY AS #2 GetSize& = LOF(2) CLOSE #2 END FUNCTION FUNCTION Match% (Filename$, WildCard$) 'checks to see if Filename$ matches Wildcard$ 'first seperate the first part and extention in filename$ x = INSTR(Filename$, ".") IF x THEN Ext$ = MID$(Filename$, x + 1) First$ = LEFT$(Filename$, x - 1) ELSE Ext$ = " " First$ = Filename$ END IF IF LEN(First$) < 8 THEN First$ = First$ + STRING$(8 - LEN(First$), "?") IF LEN(Ext$) < 3 THEN Ext$ = Ext$ + STRING$(3 - LEN(Ext$), "?") 'put them back together with ?'s added where there are blanks FiName$ = First$ + "." + Ext$ 'now change wildcard from (for instance) "TE*.*" to "TE??????.???" IF INSTR(WildCard$, ".") = 0 THEN WildCard$ = WildCard$ + ".*" END IF IF RIGHT$(WildCard$, 1) = "." THEN WildCard$ = WildCard$ + "*" IF LEFT$(WildCard$, 1) = "." THEN WildCard$ = "*" + WildCard$ Temp$ = UCASE$(WildCard$) Temp2$ = "" InExt = 0 'go through Temp$ (wildcard$) byte by byte, and when we come upon a *, add 'the appropriate amount of ?'s FOR x = 1 TO LEN(Temp$) t$ = MID$(Temp$, x, 1) IF t$ <> "*" THEN 'assume that its good IF t$ = "." THEN Dot = x IF LEN(Temp2$) < 8 THEN Temp2$ = Temp2$ + STRING$(8 - LEN(Temp2$), "?") END IF Temp2$ = Temp2$ + t$ ELSE 'fill it with ?'s 'if we're in the filename part, add 8-len(temp$) ?'s IF LEN(Temp2$) < 8 THEN Temp2$ = Temp2$ + STRING$(8 - LEN(Temp2$), "?") ELSE 'otherwise add 3-len(temp$) Temp2$ = Temp2$ + STRING$(3 - LEN(MID$(Temp$, Dot + 1)), "?") END IF 'and continue on.. END IF NEXT x 'trim off any extra ?'s we might've added accidentally if they put in more 'than 1 * on the same half of the period. IF LEN(Temp2$) > 12 THEN Temp2$ = LEFT$(Temp2$, 12) Temp$ = Temp2$: Temp2$ = "" 'now compare Temp$ (the fixed up wildcard) and Filename$ FOR x = 1 TO LEN(Temp$) a$ = MID$(Temp$, x, 1) B$ = MID$(FiName$, x, 1) IF a$ <> B$ THEN IF a$ <> "?" THEN 'No match Match = 0 EXIT FUNCTION END IF END IF NEXT x 'found a match! Match = -1 END FUNCTION SUB RemoveRecords SHARED Selected, Total GET #1, Selected, Cat 'clear the top FOR x = 1 TO 3 LOCATE x, 1 PRINT SPACE$(80); NEXT x LOCATE 1, 1 PRINT "[Remove " + RTRIM$(Cat.Filename) + "] "; PRINT "[File is "; IF DIR$(RTRIM$(Cat.Filename)) = "" THEN PRINT "not "; END IF PRINT "on disk]"; LOCATE 3, 1 LOCATE , , 1, 12, 13 PRINT "Are you sure you want to remove this record? "; x$ = YesNo$ LOCATE , , 0 GET #1, Selected, Cat Temp$ = RTRIM$(Cat.Filename) ' this part is really neat! It grabs all the records in front of the one ' you're about to delete, and it pulls them all forward.. then (heres the ' REALLY neato party) it chops the length of the file using an interrupt, ' so the record is actually physically removed from the file!! IF x$ = "Y" THEN 'bring all the files in front of it down 1.. FOR I = Selected TO Total - 1 GET #1, I + 1, Cat PUT #1, I, Cat NEXT I Handle = FILEATTR(1, 2) x = TruncateFile(Handle, LOF(1) - LEN(Cat)) 'subtract 1 record IF DIR$(RTRIM$(Temp$)) <> "" THEN LOCATE 3, 1 LOCATE , , 1, 12, 13 PRINT SPACE$(80); LOCATE 3, 1 PRINT "Delete file too? "; x$ = YesNo$ LOCATE , , 0 IF x$ = "Y" THEN KILL RTRIM$(Temp$) END IF END IF END IF END SUB SUB ScanForNew 'Scans for new files in the directory that aren't in the database SHARED Total 'clear the top LOCATE 1, 1 PRINT SPACE$(240); LOCATE 1, 1, 1, 12, 13 PRINT "[Scanning for new files]" 'get a list of all the files on record FileList$ = AllFiles$ 'get each file x$ = DIR$("*.*") DO WHILE LEN(x$) TempFile$ = UCASE$(LEFT$(x$, LEN(x$) - 1)) 'search the database for it x = INSTR(FileList$, "+" + TempFile$ + "+") IF x = 0 AND TempFile$ <> UCASE$(RTRIM$(Filename$)) THEN 'new file 'found one! LOCATE 2, 1 PRINT "Found file: " + TempFile$ PRINT "Add to database? "; DO x$ = UCASE$(INKEY$) IF LEN(x$) THEN IF INSTR("YN" + CHR$(27), x$) THEN EXIT DO END IF LOOP IF x$ = CHR$(27) THEN LOCATE , , 0: EXIT SUB PRINT x$ x$ = UCASE$(x$) IF x$ = "Y" THEN LOCATE 3, 1 PRINT "Description: [" + SPACE$(60) + "]"; LOCATE , 15 De$ = EditString$("", 60) Cat.Description = De$ + SPACE$(60) 'fill the rest with spaces 'get the size Cat.FileSize = GetSize&(TempFile$) Cat.Filename = TempFile$ + SPACE$(12) 'save the record Total = Total + 1 PUT #1, Total, Cat ELSE LOCATE 3, 1 PRINT SPACE$(80); LOCATE 3, 1 PRINT "Do you want me to delete it? "; x$ = YesNo$ IF x$ = "Y" THEN KILL TempFile$ END IF END IF 'clear the top FOR x = 1 TO 3 LOCATE x, 1 PRINT SPACE$(80); NEXT x LOCATE 1, 1 PRINT "[Scanning for new files]" END IF x$ = DIR$("") LOOP END SUB SUB Scroll (Direction%, Top%, Left%, Bottom%, Right%, Lines%, Attr%) DIM Reg AS RegType 'need $include qb.bi Top% = Top% - 1 Left% = Left% - 1 Bottom% = Bottom% - 1 Right% = Right% - 1 Reg.ax = Direction% + Lines% 'zero lines will clear viewport Reg.bx = Attr% * 256 'attribute for blank area Reg.cx = Top% * 256 + Left% 'Top Left Coords Reg.dx = Bottom% * 256 + Right% 'Bottom Right Coords INTERRUPT &H10, Reg, Reg END SUB SUB ScrollDN Scroll sDOWN, 5, 1, 24, 80, 1, 0 END SUB SUB ScrollUP Scroll sUP, 5, 1, 24, 80, 1, 0 END SUB SUB Sort LOCATE 1, 1: PRINT SPACE$(240); LOCATE 1, 1 PRINT "[Sorting Records]" x = LOF(1) \ LEN(Cat) DIM Temp(1 TO x) AS CatalogType PRINT "Reading..."; FOR I = 1 TO x GET #1, I, Temp(I) NEXT I PRINT "Sorting..."; FastSortI Temp(), 1, x PRINT "Writing..."; FOR I = 1 TO x PUT #1, I, Temp(I) NEXT I ERASE Temp END SUB FUNCTION TruncateFile% (Handle%, NewLength&) 'Edits the length of a file 'Handle% = FILEATTR(1, 2) 'filenumber, 2 DIM Reg AS RegTypeX 'First, position the file read/write pointer to the place where the 'truncation should take place. We can't trust BASIC's SEEK statement 'because the movement is sometimes held until the next read/write. Reg.ax = &H4200 'DOS "Set file pointer" function Reg.bx = Handle% 'We go through these steps to prevent "overflow" errors when 'NewLength& > 32767. The high word of the file position goes in CX 'and the low word goes in DX. Since BASIC treats integers and longs '"signed" variables, we need to take to extra steps to prevent 'an overflow error as we break the long integer down. DEF SEG Addr% = VARPTR(NewLength&) Reg.cx = CVI(CHR$(PEEK(Addr% + 2)) + CHR$(PEEK(Addr% + 3))) Reg.dx = CVI(CHR$(PEEK(Addr%)) + CHR$(PEEK(Addr% + 1))) CALL INTERRUPTX(&H21, Reg, Reg) IF Reg.flags AND 1 THEN Status% = Reg.ax GOTO TruncateExit END IF 'Now, write 0 bytes. Reg.ax = &H4000 'Dos "Write file or device" Reg.bx = Handle% Reg.cx = 0 'Write 0 bytes Reg.dx = 0 'These are not needed, but make Reg.ds = 0 ' sure they're zero, just in case CALL INTERRUPTX(&H21, Reg, Reg) IF Reg.flags AND 1 THEN Status% = Reg.ax END IF TruncateExit: TruncateFile% = Status% END FUNCTION SUB UpdateRecords 'Goes through all the records and makes sure their sizes are correct and that 'the file is still there. SHARED Total Removed = 0 LOCATE 1, 1: PRINT SPACE$(240); LOCATE 1, 1 PRINT "[Update Records]" PRINT "Scanning: "; FOR x = 1 TO Total LOCATE 2, 11 GET #1, x, Cat PRINT Cat.Filename + SPACE$(2); x$ = DIR$(RTRIM$(Cat.Filename)) IF LEN(x$) = 0 THEN PRINT " [File not on disk] "; LOCATE , , 1, 12, 13 d = CSRLIN: a = POS(0) LOCATE 3, 1 PRINT "Description: "; Cat.Description LOCATE d, a PRINT "Remove? "; x$ = YesNo$ IF x$ = "Y" THEN 'remove this record FOR x2 = x + 1 TO Total GET #1, x2, Cat PUT #1, x2 - 1, Cat NEXT x2 Removed = Removed + 1 END IF LOCATE , , 0 LOCATE 3, 1: PRINT SPACE$(80); GOTO SkipToEnd END IF PRINT "Size: "; x2& = GetSize&(RTRIM$(Cat.Filename)) PRINT x2&; PRINT SPACE$(6 - LEN(STR$(x2&))); Cat.FileSize = x2& PUT #1, x, Cat SkipToEnd: NEXT x Handle = FILEATTR(1, 2) x = TruncateFile(Handle, LOF(1) - (Removed * LEN(Cat))) 'erase removed 'records Total = Total - Removed END SUB FUNCTION YesNo$ DO x$ = UCASE$(INKEY$) IF LEN(x$) THEN IF INSTR("YN", x$) THEN YesNo$ = x$: EXIT FUNCTION LOOP END FUNCTION