Output of file : DIRS.SWG contained in archive :
ALLSWAGS.ZIP SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00029 DIRECTORY HANDLING ROUTINES 1 05-28-9313:37ALL SWAG SUPPORT TEAM ForEachFile Procedure IMPORT 35 ¦¶ {ã Can any one tell me a way to make pascal (TP 6.0) search aã complete drive, including all subdirectories, even onesã that are not in the path, looking For a specific Fileã extension? I.E., having the Program search For *.DOC andã saving that to a Text File?ãã Here's part of a package I'm putting together. You'd use it like this:ãã}ãã{File Test.Pas}ããUsesã Dos, Foreach;ããProcedure PrintAllDocs;ãã Procedure PrintFile(Var Dir: DirStr; Var S : SearchRec); Far;ã beginã Writeln('Found File ',Dir,S.Name);ã end;ããbeginã ForEachFile('c:\*.doc', { Give the mask where you want to start looking }ã 0, 0, { Specify File attributes here; you'll just getã normal Files With 0 }ã True, { Search recursively }ã @PrintFile); { Routine to call For each File }ãend;ããbeginã PrintAllDocs;ãend.ããã{Unit ForEach}ããUnit ForEach;ãã{ Unit With a few different "foreach" Functions. }ã{ This extract contains only ForEachFile. }ããInterfaceããUsesã Dos;ããTypeã FileStr = String[12];ã TFileAction = Procedure(Var Dir : DirStr;ã Var S : SearchRec; ConText : Word);ããProcedure ForEachFile(Mask : PathStr; { File wildcard mask, including path }ã Attr : Byte; { File attributes }ã Match : Byte; { File attributes whichã must match attr exactly }ã Subdirs : Boolean; { Whether to search recursively }ã Action : Pointer);ã{ Calls the Far local Procedure Action^ For each File found.ã Action^ should be a local Procedure With declarationã Procedure Action(Var Path : String; Var S : SearchRec); Far;ã or, if not a local Procedure,ã Procedure Action(Var Path : String; Var S : SearchRec; Dummy : Word); Far;ã Each time Action is called S will be filled in For a File matchingã the search criterion.ã}ããImplementationããFunction CallerFrame : Word;ã{ Returns the BP value of the caller's stack frame; used For passingã local Procedures and Functions around. Taken from Borland's Outlineã Unit. }ã Inline(ã $8B/$46/$00 { MOV AX,[BP] }ã );ããã { ******** File routines ********* }ããProcedure ForEachFile(Mask : PathStr; { File wildcard mask }ã Attr : Byte; { File attributes }ã Match : Byte; { Attributes which must match }ã Subdirs : Boolean; { Whether to search recursively }ã Action : Pointer);{ Action; should point toã a TFileAction local Far Procedure }ãVarã CurrentDir : DirStr;ã Doit : TFileAction Absolute Action;ã Frame : Word;ãã Procedure DoDir;ã { Tests all Files in current directory. Assumes currentdir has trailingã backslash }ã Varã S : SearchRec;ã beginã FindFirst(CurrentDir + Mask, Attr, S);ã While DosError = 0 doã beginã if (S.Attr and Match) = (Attr and Match) thenã Doit(CurrentDir, S, Frame);ã FindNext(S);ã end;ã end;ãã Function RealDir(Name : FileStr) : Boolean;ã beginã RealDir := (Name <> '.') and (Name <> '..');ã end;ãã Procedure AddBackslash;ã beginã CurrentDir := CurrentDir + '\';ã end;ãã Procedure DoAllDirs;ã Varã S : SearchRec;ã OldLength : Byte;ãã Procedure AddSuffix(Suffix : FileStr); { Separate proc to save stack space }ã beginã CurrentDir := Copy(CurrentDir, 1, OldLength) + Suffix;ã end;ãã beginã OldLength := Length(CurrentDir);ã DoDir;ã AddSuffix('*.*');ã FindFirst(CurrentDir, Directory, S);ã While DosError = 0 doã beginã if S.Attr = Directory thenã beginã if RealDir(S.Name) thenã beginã AddSuffix(S.Name);ã AddBackslash;ã DoAllDirs; { do directory recursively }ã end;ã end;ã FindNext(S);ã end;ã end;ããVarã Name : NameStr;ã Ext : ExtStr;ããbegin { ForEachFile }ã FSplit(Mask, CurrentDir, Name, Ext);ã Mask := Name+Ext;ã Frame := CallerFrame;ã if CurrentDir[Length(CurrentDir)] <> '\' thenã AddBackslash;ã if Subdirs thenã DoAllDirsã elseã DoDir;ãend;ããend.ã 2 05-28-9313:37ALL SWAG SUPPORT TEAM Search ALL Dirs and Subs IMPORT 7 ¦¶1~ Uses Crt, Dos, WinDos;ãProcedure SearchSubDirs(Dir:PathStr;Target:SearchRec);ãVarã FoundDir: TSearchRec;ã FileSpec: PathStr;ã Path : DirStr;ã DummyName: NameStr;ã DummyExt : ExtStr;ãbeginã If KeyPressed then Repeat Until KeyPressed;ã FileSpec:= Dir + '*.';ã FindFirst('*.*', AnyFile, FoundDir);ã While (DosError = 0) doã beginã With FoundDir doã beginã If Name[1] <> '.' thenã if Directory and Attr <> 0 thenã beginã FSplit(FileSpec,Path,DummyName,DummyExt);ã FindFirst(Path + Name + '\' ,Target);ã end;ã end; {with FoundDir}ã if KeyPressed then Pause;ã FindNext(FoundDir);ã end; {read loop}ã If DosError <> 18 then DosErrorExit;ãend;ã 3 05-28-9313:37ALL SWAG SUPPORT TEAM Search All Dirs & Subs #2IMPORT 24 ¦¶¿ß AH>>Hi everyone. I have a small problem. How does one go about accessingã >>EVERY File in every directory, sub-directory on a drive? I guess this isã >>part of the last question, but how do you access every sub-directory?ããUnit FindFile;ã{$R-}ãInterfaceããUses Dos;ããTypeã FileProc = Procedure ( x : PathStr );ããProcedure FindFiles (DirPath : PathStr; (* initial path *)ã Mask : String; (* mask to look For *)ã Recurse : Boolean; (* recurse into sub-dirs? *)ã FileDoer : FileProc); (* what to do With found *)ãã(* Starting at
, FindFiles will pass the path of all the Filesã it finds that match to the Procedure. if ã is True, all such Files in subdirectories beneath will beã visited as well. if is False, the names of subdirectoriesã in will be passed as well. *)ããImplementationããProcedure FindFiles (DirPath : PathStr; (* initial path *)ã Mask : String; (* mask to look For *)ã Recurse : Boolean; (* recurse into sub-dirs? *)ã FileDoer : FileProc); (* what to do With found *)ãã Procedure SubVisit ( DirPath : PathStr );ã Varã Looking4 : SearchRec;ãã beginã FindFirst ( Concat ( DirPath, Mask ), AnyFile, looking4);ã While ( DosError = 0 ) Do beginã if ( looking4.attr and ( VolumeID + Directory ) ) = 0ã then FileDoer ( Concat ( DirPath, looking4.name ) );ã FindNext ( Looking4 );ã end; (* While *)ã if Recurseã then beginã FindFirst ( Concat ( DirPath, '*.*' ), AnyFile, looking4);ã While ( DosError = 0 ) and ( looking4.name [1] = '.' ) Doã FindNext (looking4); (* skip . and .. directories *)ã While ( DosError = 0 ) Do beginã if ( ( looking4.attr and Directory ) = Directory )ã then SubVisit ( Concat ( DirPath, looking4.name, '\' ) );ã FindNext ( Looking4 );ã end; (* While *)ã end; (* if recursing *)ã end; (* SubVisit *)ãããbegin (* FindFiles *)ã SubVisit ( DirPath );ãend; (* FindFiles *)ããend.ãã --------------------------------------------------------------------ããProgram Visit;ããUses Dos, FindFile;ãã{$F+}ãProcedure FoundOne ( Path : PathStr ); (* MUST be Compiled With $F+ *)ã{$F-}ãbeginã WriteLn ( Path );ãend;ããbeginã WriteLn ( '-------------------------------------------------------------');ã FindFiles ( '\', '*.*', True, FoundOne );ã WriteLn ( '-------------------------------------------------------------');ãend.ãã -----------------------------------------------------------------------ããFoundOne will be passed every File & subdirectory. if you just want theãsubdirectories, ignore any name that doesn't end in a '\' Character!ã 4 05-28-9313:37ALL SWAG SUPPORT TEAM ALLDIRS4.PAS IMPORT 19 ¦¶D¿ {ã>Is there any easy way do turn *.* wildcards into a bunch of Filenames?ã>This may be confusing, so here's what I want to do:ã>I know C, basic, pascal, and batch. (but not too well)ã>I want to make a Program to read Files from c:\ece\ and, according to myã>Filespecs ( *.* *.dwg plot???.plt hw1-1.c) I want the Program to takeã>each File individually, and Compress it and put it on b:. I also wantã>the Program to work in reverse. I.E.: unpack Filespecs from b: andã>into c:. I want this because I take so many disks to school, and Iã>don't like packing and unpacking each File individually. I also don'tã>want one big archive. Any suggestions as to how to do it, or what Iã>could do is appreciated.ããThe easiest way would be to use the findfirst() and findnext()ãProcedures. Here's a stub Program in TP. You'll need to put code inãthe main routine to handle command line arguments, and call fsplit()ãto split up the Filenames to pass to searchDir() or searchAllDirs().ãthen just put whatever processing you want to do With each File inãthe process() Procedure.ã}ããUsesã Dos, Crt;ããVarã Path : PathStr;ã Dir : DirStr;ã Name : NameStr;ã Ext : ExtStr;ã FullName : PathStr;ã F : SearchRec;ã Ch : Char;ã I : Integer;ããProcedure Process(dir : DirStr; s : SearchRec);ãbeginã Writeln(dir, s.name);ãend;ããã{ã Both searchDir and searchAllDirs require the following parametersã path - the path to the File, which must end With a backslash.ã if there is no ending backslash these won't work.ã fspec - the File specification.ã}ããProcedure SearchDir(Path : PathStr; fspec : String);ãVarã f : SearchRec;ãbeginã Findfirst(Path + fspec, AnyFile, f);ã While DosError = 0 doã beginã Process(path, f);ã Findnext(f);ã end;ãend;ããProcedure searchAllDirs(path : pathStr; fspec : String);ãVarã d : SearchRec;ãbeginã SearchDir(Path, fspec);ã FindFirst(Path + '*.*', Directory, d);ã While DosError = 0 doã beginã if (d.Attr and Directory = Directory) and (d.name[1] <> '.') thenã beginã SearchAllDirs(Path + d.name + '\', fspec);ã end;ã Findnext(d);ã end;ãend;ããbeginã SearchAllDirs( '\', '*.*' );ãend.ã 5 05-28-9313:37ALL SWAG SUPPORT TEAM ALLDIRS5.PAS IMPORT 11 ¦¶ {ã> Can any one tell me a way to make pascal (TP 6.0) search a Completeã> drive, including all subdirectories, even ones that are not in theã> path, looking For a specific File extension? I.E., having the Programã> search For *.doC and saving that to a Text File?ããOk, here goes nothing.ã}ãã{$M 65000 0 655360}ã{Assign enough stack space For recursion}ããProgram FindAllFiles;ããUses Dos;ããVarã FileName : Text;ããProcedure ScanDir(path : PathStr);ããVarã SearchFile : SearchRec;ãbeginã if Path[Length(Path)] <> '\' thenã Path := Path + '\';ã FindFirst(Path + '*.*', $37, SearchFile); { Find Files and Directories }ã While DosError = 0 do { While There are more Files }ã beginã if ((SearchFile.Attr and $10) = $10) and (SearchFile.Name[1] <> '.') thenã ScanDir(Path + SearchFile.Name)ã { Found a directory Make sure it's not . or .. Scan this dir also }ã elseã if Pos('.doC',SearchFile.Name)>0 thenã Writeln(FileName, Path + SearchFile.Name);ã { if the .doC appears in the File name, Write path to File. }ã FindNext(SearchFile);ã end;ãend;ããbeginã Assign(FileName,'doCS'); { File to contain list of .doCs }ã ReWrite(FileName);ã ScanDir('C:\'); { Drive to scan. }ã Close(FileName);ãend.ã 6 05-28-9313:37ALL SWAG SUPPORT TEAM DELTREE.PAS IMPORT 8 ¦¶e% Procedure ClrDir ( path : pathStr );ããVar FileInfo : searchRec;ã f : File;ã path2 : pathStr;ã s : String;ããbegin FindFirst ( path + '\*.*', AnyFile, FileInfo );ã While DosError = 0 Doã begin if (FileInfo.Name[1] <> '.') and (FileInfo.attr <> VolumeId) thenã if ( (FileInfo.Attr and Directory) = Directory ) thenã begin Path2 := Path + '\' + FileInfo.Name;ã ClrDir ( path2 );ã endã elseã if ((FileInfo.Attr and VolumeID) <> VolumeID) then beginã Assign ( f, path + '\' + FileInfo.Name );ã Erase ( f );ã end;ãã FindNext ( FileInfo );ã end;ãã if (DosError = 18) and not ((Length(path) = 2)ã and ( path[2] = ':')) thenã RmDir ( path );ããend;ã 7 05-28-9313:37ALL SWAG SUPPORT TEAM DIRDEMO.PAS IMPORT 54 ¦¶Üì { DIRDEMO.PASã Author: Trevor Carlsen. Released into the public domain 1989ã Last modification 1992.ã Demonstrates in a very simple way how to display a directory in a screenã Window and scroll backwards or Forwards. }ããUsesã Dos,ã Crt,ã keyinput;ããTypeã str3 = String[3];ã str6 = String[6];ã str16 = String[16];ã sType = (_name,_ext,_date,_size);ã DirRec = Recordã name : NameStr;ã ext : ExtStr;ã size : str6;ã date : str16;ã Lsize,ã Ldate : LongInt;ã dir : Boolean;ã end;ããConstã maxdir = 1000; { maximum number of directory entries }ã months : Array[1..12] of str3 =ã ('Jan','Feb','Mar','Apr','May','Jun',ã 'Jul','Aug','Sep','Oct','Nov','Dec');ã WinX1 = 14; WinX2 = 1;ã WinY1 = 65; WinY2 = 23;ã LtGrayOnBlue = $17;ã BlueOnLtGray = $71;ã page = 22;ã maxlines : Word = page;ããTypeã DataArr = Array[1..maxdir] of DirRec;ããVarã DirEntry : DataArr;ã x, numb : Integer;ã path : DirStr;ã key : Byte;ã finished : Boolean;ã OldAttr : Byte;ããProcedure quicksort(Var s; left,right : Word; SortType: sType);ã Varã data : DataArr Absolute s;ã pivotStr,ã tempStr : String;ã pivotLong,ã tempLong : LongInt;ã lower,ã upper,ã middle : Word;ãã Procedure swap(Var a,b);ã Var x : DirRec Absolute a;ã y : DirRec Absolute b;ã t : DirRec;ã beginã t := x;ã x := y;ã y := t;ã end;ãã beginã lower := left;ã upper := right;ã middle:= (left + right) div 2;ã Case SortType ofã _name: pivotStr := data[middle].name;ã _ext : pivotStr := data[middle].ext;ã _size: pivotLong := data[middle].Lsize;ã _date: pivotLong := data[middle].Ldate;ã end; { Case SortType }ã Repeatã Case SortType ofã _name: beginã While data[lower].name < pivotStr do inc(lower);ã While pivotStr < data[upper].name do dec(upper);ã end;ã _ext : beginã While data[lower].ext < pivotStr do inc(lower);ã While pivotStr < data[upper].ext do dec(upper);ã end;ã _size: beginã While data[lower].Lsize < pivotLong do inc(lower);ã While pivotLong < data[upper].Lsize do dec(upper);ã end;ã _date: beginã While data[lower].Ldate < pivotLong do inc(lower);ã While pivotLong < data[upper].Ldate do dec(upper);ã end;ã end; { Case SortType }ã if lower <= upper then beginã swap(data[lower],data[upper]);ã inc(lower);ã dec(upper);ã end;ã Until lower > upper;ã if left < upper then quicksort(data,left,upper,SortType);ã if lower < right then quicksort(data,lower,right,SortType);ã end; { quicksort }ããFunction Form(st : String; len : Byte): String;ã { Replaces spaces in a numeric String With zeroes }ã Varã x : Byte ;ã beginã Form := st;ã For x := 1 to len doã if st[x] = ' ' thenã Form[x] := '0'ã end;ããProcedure ReadDir(Var count : Integer);ã { Reads the current directory and places in the main Array }ã Varã DirInfo : SearchRec;ãã Procedure CreateRecord;ã Varã Dt : DateTime;ã st : str6;ã beginã With DirEntry[count] do beginã FSplit(DirInfo.name,path,name,ext); { Split File name up }ã if ext[1] = '.' then { get rid of dot }ã ext := copy(ext,2,3);ã name[0] := #8; ext[0] := #3; { Force to a set length For Formatting }ã Lsize := DirInfo.size;ã Ldate := DirInfo.time;ã str(DirInfo.size:6,size);ã UnPackTime(DirInfo.time,Dt);ã date := '';ã str(Dt.day:2,st);ã date := st + '-' + months[Dt.month] + '-';ã str((Dt.year-1900):2,st);ã date := date + st + #255#255;ã str(Dt.hour:2,st);ã date := date + st + ':';ã str(Dt.Min:2,st);ã date := date + st;ã date := Form(date,length(date));ã dir := DirInfo.attr and Directory = Directory;ã end; { With }ã end; { CreateRecord }ãã begin { ReadDir }ã count := 0; { For keeping a Record of the number of entries read }ã FillChar(DirEntry,sizeof(DirEntry),32); { initialize the Array }ã FindFirst('*.*',AnyFile,DirInfo);ã While (DosError = 0) and (count < maxdir) do beginã inc(count);ã CreateRecord;ã FindNext(DirInfo);ã end; { While }ã if count < page thenã maxlines := count;ã quicksort(DirEntry,1,count,_name);ã end; { ReadDir }ããProcedure DisplayDirectory(n : Integer);ã Varã x,y : Integer;ã beginã y := 1;ã For x := n to n + maxlines doã With DirEntry[x] do beginã GotoXY(4,y);inc(y);ã Write(name,' ');ã Write(ext,' ');ã if dir then Write('')ã else Write(' ');ã Write(size:8,date:18);ã end; { With }ã end; { DisplayDirectory }ããbegin { main }ã ClrScr;ã GotoXY(5,24);ã OldAttr := TextAttr;ã TextAttr := BlueOnLtGray;ã Write(' F1=Sort by name F2=Sort by extension F3=Sort by size F4=Sort by date ');ã GotoXY(5,25);ã Write(' Use arrow keys to scroll through directory display - quits ');ã TextAttr := LtGrayOnBlue;ã Window(WinX1,WinX2,WinY1,WinY2); { make the Window }ã ClrScr;ã HiddenCursor;ã ReadDir(numb);ã x := 1; finished := False;ã Repeatã DisplayDirectory(x); { display maxlines Files }ã Case KeyWord ofã F1 {name} : beginã x := 1;ã quicksort(DirEntry,1,numb,_name);ã end;ã F2 {ext} : beginã x := 1;ã quicksort(DirEntry,1,numb,_ext);ã end;ã F3 {size} : beginã x := 1;ã quicksort(DirEntry,1,numb,_size);ã end;ã F4 {date} : beginã x := 1;ã quicksort(DirEntry,1,numb,_date);ã end;ã home : x := 1;ã endKey : x := numb - maxlines;ã UpArrow : if x > 1 thenã dec(x);ã DownArrow : if x < (numb - maxlines) thenã inc(x);ã PageDn : if (x + page) > (numb - maxlines) thenã x := numb - maxlinesã else inc(x,page);ã PageUp : if (x - page) > 0 thenã dec(x,page)ã else x := 1;ã escape : finished := Trueã end; { Case }ã Until finished;ã NormalCursor;ã TextAttr := OldAttr;ã ClrScr;ãend.ãã 8 05-28-9313:37ALL SWAG SUPPORT TEAM DIREXIST.PAS IMPORT 7 ¦¶5_ {ã re: Finding a directoryãã>Obviously that's not the quickest routine in the world, and thoughã>it works, I was wondering if you have anything easier/faster?ãã ...I don't know how much better this routine is, but you mayã want to give it a try:ã}ãã{ Determine if a directory exists. }ããFunction DirExist(st_Dir : DirStr) : Boolean;ãVarã wo_Fattr : Word;ã fi_Temp : File;ãbeginã assign(fi_Temp, (st_Dir + '.'));ã getfattr(fi_Temp, wo_Fattr);ã if (Doserror <> 0) thenã DirExist := Falseã elseã DirExist := ((wo_Fattr and directory) <> 0)ãend; { DirExist. }ãã{ãnotE: The "DirStr" Type definition is found in the standard TPã Dos Unit. Add this Unit to your Program's "Uses" statementã to use this routine.ã}ã 9 05-28-9313:37ALL SWAG SUPPORT TEAM DIRTREE.PAS IMPORT 105 ¦¶:W Program Vtree2;ãã{$B-,D+,R-,S-,V-}ã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Uses and GLOBAL VarIABLES & ConstANTS ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããUsesã Crt, Dos;ããConstã NL = #13#10;ã NonVLabel = ReadOnly + Hidden + SysFile + Directory + Archive;ããTypeãã FPtr = ^Dir_Rec;ãã Dir_Rec = Record { Double Pointer Record }ã DirName : String[12];ã DirNum : Integer;ã Next : Fptr;ã end;ãã Str_Type = String[65];ããVarã Version : String;ã Dir : str_Type;ã Loop : Boolean;ã Level : Integer;ã Flag : Array[1..5] of String[20];ã TreeOnly : Boolean;ã Filetotal : LongInt;ã Bytetotal : LongInt;ã Dirstotal : LongInt;ã tooDeep : Boolean;ã ColorCnt : Byte;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure Beepit ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure Beepit;ããbeginã Sound (760); { Beep the speaker }ã Delay (80);ã NoSound;ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure Usage ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure Usage;ããbeginã BEEPIT;ã Write (NL,ã 'Like the Dos TREE command, and similar to PC Magazine''s VTREE, but gives',NL,ã 'you a Graphic representation of your disk hierarchical tree structure and',NL,ã 'the number of Files and total Bytes in each tree node (optionally can be',NL,ã 'omitted). Also allows starting at a particular subdirectory rather than',NL,ã 'displaying the entire drive''s tree structure. Redirection of output and',NL,ã 'input is an option.',NL,NL, 'USAGE: VTREE2 {path} {/t} {/r}',NL,NL,ã '/t or /T omits the number of Files and total Bytes inFormation.',NL,ã '/r or /R activates redirection of input and output.',NL,NL, Version);ã Halt;ãend;ãã{ãÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã³ Function Format ³ãÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããFunction Format (Num : LongInt) : String; {converts Integer to String}ã {with commas inserted }ãVarã NumStr : String[12];ã Place : Byte;ããbeginã Place := 3;ã STR (Num, NumStr);ã Num := Length (NumStr); {re-use Num For Length value }ãã While Num > Place do {insert comma every 3rd place}ã beginã inSERT (',',NumStr, Num - (Place -1));ã inC (Place, 3);ã end;ãã Format := NumStr;ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure DisplayDir ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure DisplayDir (DirP : str_Type; DirN : str_Type; Levl : Integer;ã NumSubsVar2 : Integer; SubNumVar2 : Integer;ã NumSubsVar3 : Integer;ã NmbrFil : Integer; FilLen : LongInt);ãã{NumSubsVar2 is the # of subdirs. in previous level;ã NumSumsVar3 is the # of subdirs. in the current level.ã DirN is the current subdir.; DirP is the previous path}ããConstã LevelMax = 5;ãVarã BegLine : String;ã MidLine : String;ã Blank : String;ã WrtStr : String;ããbeginãã if Levl > 5 thenã beginã BEEPIT;ã tooDeep := True;ã Exit;ã end;ãã Blank := ' '; { Init. Variables }ã BegLine := '';ã MidLine := ' ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ';ãã if Levl = 0 then { ã al handling For }ã if Dir = '' then { initial (0) dir. level }ã if not TreeOnly thenã WrtStr := 'ROOT ÄÄ'ã elseã WrtStr := 'ROOT'ã elseã if not TreeOnly thenã WrtStr := DirP + ' ÄÄ'ã elseã WrtStr := DirPã elseã begin { Level 1+ routines }ã if SubNumVar2 = NumSubsVar2 then { if last node in subtree, }ã begin { use ÀÄ symbol & set flag }ã BegLine := 'ÀÄ'; { padded With blanks }ã Flag[Levl] := ' ' + Blank;ã endã else { otherwise, use ÃÄ symbol }ã begin { & set flag padded With }ã BegLine := 'ÃÄ'; { blanks }ã Flag[Levl] := '³' + Blank;ã end;ãã Case Levl of { Insert ³ & blanks as }ã 1: BegLine := BegLine; { needed, based on level }ã 2: Begline := Flag[1] + BegLine;ã 3: Begline := Flag[1] + Flag[2] + BegLine;ã 4: Begline := Flag[1] + Flag[2] + Flag[3] + BegLine;ã 5: Begline := Flag[1] + Flag[2] + Flag[3] + Flag[4] + BegLine;ã end; {end Case}ãã if (NumSubsVar3 = 0) then { if cur. level has no }ã WrtStr := BegLine + DirN { subdirs., leave end blank}ã elseã beginã WrtStr := BegLine + DirN + COPY(Midline,1,(13-Length(DirN)));ã if Levl < LevelMax thenã WrtStr := WrtStr + 'Ä¿'ã else { if level 5, special }ã begin { end to indicate more }ã DELETE (WrtStr,Length(WrtStr),1); { levels }ã WrtStr := WrtStr + '¯';ã end;ã end;ã end; { end level 1+ routines }ãã if ODD(ColorCnt) thenã TextColor (3)ã elseã TextColor (11);ã inC (ColorCnt);ãã if ((Levl < 4) or ((Levl = 4) and (NumSubsVar3=0))) and not TreeOnly thenã WriteLn (WrtStr,'':(65-Length(WrtStr)), Format(NmbrFil):3,ã Format(FilLen):11)ã elseã WriteLn (WrtStr); { Write # of Files & Bytes }ã { only if it fits, else }ãend; { Write only tree outline }ããã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure DisplayHeader ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure DisplayHeader;ããbeginã WriteLn ('DIRECtoRIES','':52,'FileS',' ByteS');ã WriteLn ('ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure DisplayTally ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure DisplayTally;ããbeginã WriteLn('':63,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');ã WriteLn('NUMBER of DIRECtoRIES: ', Dirstotal:3, '':29,ã 'toTALS: ', Format (Filetotal):5, Format (Bytetotal):11);ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure ReadFiles ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure ReadFiles (DirPrev : str_Type; DirNext : str_Type;ã SubNumVar1 : Integer; NumSubsVar1 : Integer);ããVarã FileInfo : SearchRec;ã FileBytes : LongInt;ã NumFiles : Integer;ã NumSubs : Integer;ã Dir_Ptr : FPtr;ã CurPtr : FPtr;ã FirstPtr : FPtr;ããbeginã FileBytes := 0;ã NumFiles := 0;ã NumSubs := 0;ã Dir_Ptr := nil;ã CurPtr := nil;ã FirstPtr := nil;ãã if Loop thenã FindFirst (DirPrev + DirNext + '\*.*', NonVLabel, FileInfo);ã Loop := False; { Get 1st File }ãã While DosError = 0 do { Loop Until no more Files }ã beginã if (FileInfo.Name <> '.') and (FileInfo.Name <> '..') thenã beginã if (FileInfo.attr = directory) then { if fetched File is dir., }ã begin { store a Record With dir. }ã NEW (Dir_Ptr); { name & occurence number, }ã Dir_Ptr^.DirName := FileInfo.name;{ and set links to }ã inC (NumSubs); { other Records if any }ã Dir_Ptr^.DirNum := NumSubs;ã if CurPtr = nil thenã beginã Dir_Ptr^.Next := nil;ã CurPtr := Dir_Ptr;ã FirstPtr := Dir_Ptr;ã endã elseã beginã Dir_Ptr^.Next := nil;ã CurPtr^.Next := Dir_Ptr;ã CurPtr := Dir_Ptr;ã end;ã endã elseã begin { Tally # of Bytes in File }ã FileBytes := FileBytes + FileInfo.size;ã inC (NumFiles); { Increment # of Files, }ã end; { excluding # of subdirs. }ã end;ã FindNext (FileInfo); { Get next File }ã end; {end While}ãã Bytetotal := Bytetotal + FileBytes;ã Filetotal := Filetotal + NumFiles;ã Dirstotal := Dirstotal + NumSubs;ãã DisplayDir (DirPrev, DirNext, Level, NumSubsVar1, SubNumVar1, NumSubs,ã NumFiles, FileBytes); { Pass info to & call }ã inC (Level); { display routine, & inc. }ã { level number }ããã While (FirstPtr <> nil) do { if any subdirs., then }ã begin { recursively loop thru }ã Loop := True; { ReadFiles proc. til done }ã ReadFiles ((DirPrev + DirNext + '\'),FirstPtr^.DirName,ã FirstPtr^.DirNum, NumSubs);ã FirstPtr := FirstPtr^.Next;ã end;ãã DEC (Level); { Decrement level when }ã { finish a recursive loop }ã { call to lower level of }ã { subdir. }ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ Procedure Read_Parm ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããProcedure Read_Parm;ããVarã Cur_Dir : String;ã Param : String;ã i : Integer;ããbeginãã if ParamCount > 3 thenã Usage;ã Param := '';ãã For i := 1 to ParamCount do { if either param. is a T, }ã begin { set TreeOnly flag }ã Param := ParamStr(i);ã if Param[1] = '/' thenã Case Param[2] ofã 't','T': beginã TreeOnly := True;ã if ParamCount = 1 thenã Exit;ã end; { Exit if only one param }ãã 'r','R': beginã ASSIGN (Input,''); { Override Crt Unit, & }ã RESET (Input); { make input & output }ã ASSIGN (Output,''); { redirectable }ã REWrite (Output);ã if ParamCount = 1 thenã Exit;ã end; { Exit if only one param }ã '?' : Usage;ãã elseã Usage;ã end; {Case}ã end;ãã GETDIR (0,Cur_Dir); { Save current dir }ã For i := 1 to ParamCount doã beginã Param := ParamStr(i); { Set Var to param. String }ã if (POS ('/',Param) = 0) thenã beginã Dir := Param;ã{$I-} CHDIR (Dir); { Try to change to input }ã if Ioresult = 0 then { dir.; if it exists, go }ã begin { back to orig. dir. }ã{$I+} CHDIR (Cur_Dir);ã if (POS ('\',Dir) = Length (Dir)) thenã DELETE (Dir,Length(Dir),1); { Change root symbol back }ã Exit; { to null, 'cause \ added }ã end { in later }ã elseã beginã BEEPIT;ã WriteLn ('No such directory -- please try again.');ã HALT;ã end;ã end;ã end;ãend;ãã{ã ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ã ³ MAin Program ³ã ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙã}ããbeginãã Version := 'Version 1.6, 7-16-90 -- Public Domain by John Land';ã { Sticks in EXE File }ãã Dir := ''; { Init. global Vars. }ã Loop := True;ã Level := 0;ã TreeOnly := False;ã tooDeep := False;ã Filetotal := 0;ã Bytetotal := 0;ã Dirstotal := 1; { Always have a root dir. }ã ColorCnt := 1;ãã ClrScr;ãã if ParamCount > 0 thenã Read_Parm; { Deal With any params. }ãã if not TreeOnly thenã DisplayHeader;ãã ReadFiles (Dir,'',0,0); { do main read routine }ãã TextColor(Yellow);ãã if not TreeOnly thenã DisplayTally; { Display totals }ãã if tooDeep thenã WriteLn (NL,NL,'':22,'¯ CANnot DISPLAY MorE THAN 5 LEVELS ®',NL);ã { if ReadFiles detects >5 }ã { levels, tooDeep flag set}ããend.ã 10 05-28-9313:37ALL SWAG SUPPORT TEAM DIRVIEW.PAS IMPORT 16 ¦¶Ì3 {ãWell, here goes...a directory viewer, sorry it has no box but theãcommand that i used to create the box was from a Unit. Weel, the Programãis very "raw" but i think it's enough to give you an idea...ã}ããProgram ListBox;ããUsesã Crt, Dos;ããConstã S = ' ';ããVarã List : Array[1..150] of String[12];ã AttrList : Array[1..150] of String[15];ã Pos, First : Integer;ã C : Char;ã Cont : Integer;ã DirInfo : SearchRec;ã NumFiles : Integer;ããbeginã TextBackground(Black);ã TextColor(LightGray);ã ClrScr;ãã For Cont := 1 to 15 doã beginã List[Cont] := '';ã AttrList[Cont] := '';ã end;ãã NumFiles := 0;ã FindFirst('C:\*.*', AnyFile, DirInfo);ãã While DosError = 0 doã beginã Inc(NumFiles, 1);ã List[NumFiles] := Concat(DirInfo.Name,ã Copy(S, 1, 12 - Length(DirInfo.Name)));ã If (DirInfo.Attr = $10) Thenã AttrList[NumFiles] := ''ã Elseã Str(DirInfo.Size, AttrList[NumFiles]);ã AttrList[NumFiles] := Concat(AttrList[NumFiles],ã Copy(S, 1, 9 - Length(AttrList[NumFiles])));ã FindNext(DirInfo);ã end;ãã First := 1;ã Pos := 1;ãã Repeatã For Cont := First To First + 15 doã beginã If (Cont - First + 1 = Pos) Thenã beginã TextBackground(Blue);ã TextColor(Yellow);ã endã Elseã beginã TextBackGround(Black);ã TextColor(LightGray);ã end;ã GotoXY(30, Cont - First + 3);ã Write(' ', List[Cont], ' ', AttrList[Cont]);ã end;ã C := ReadKey;ã If (C = #72) Thenã If (Pos > 1) Thenã Dec(Pos, 1)ã Elseã If (First > 1) Thenã Dec(First,1);ãã If (C = #80) Thenã If (Pos < 15) Thenã Inc(Pos, 1)ã Elseã If (First + 15 < NumFiles) Thenã Inc(First,1);ã Until (Ord(c) = 13);ãend.ã 11 05-28-9313:37ALL SWAG SUPPORT TEAM FAST-DEL.PAS IMPORT 8 ¦¶ÀÐ { DR> DEL/ERASE command is able to erase an entire directory by using DEL *.*ã DR> With such speed. It clearly has a method other than deleting File byã DR> File.ãã Function $41 of Int $21 will do what you want. You'll need toãmake an ASCIIZ Filename of the path and File(s), and set a Pointerãto it in DS:DX. When it returns, if the carry flag (CF) is set,ãthen AX holds the Dos error code.ã}ãFunction DosDelete (FileName : PathStr) : Word; {returns error if any}ãVar Regs : Registers;ãbeginã FileName[65] := 0; {make asciiz- maybe, not sure}ã Regs.DS := Seg(FileName); {segment to String}ã Regs.DX := offset(FileName)+1; {add one since f[0] is length}ã Regs.AH := $41;ã Regs.AL := 0; {Initialize}ã Intr ($21, Regs);ã if Regs.AL <> 0 {error} then DosDelete := Regs.AX else DosDelete := 0;ãend;ã 12 05-28-9313:37ALL SWAG SUPPORT TEAM MAKEDIR1.PAS IMPORT 19 ¦¶î+ Program MakeChangeDir;ãã{ Purpose: - Make directories where they don't exist }ã{ }ã{ Useful for: - Installation Type Programs }ã{ }ã{ Useful notes: - seems to handles even directories With extentions }ã{ (i.e. DIRDIR.YYY) }ã{ - there are some defaults that have been set up :- }ã{ change if needed }ã{ - doesn't check to see how legal the required directory }ã{ is (i.e. spaces, colon in the wrong place, etc.) }ã{ }ã{ Legal junk: - this has been released to the public as public domain }ã{ - if you use it, give me some credit! }ã{ }ããVarã Slash : Array[1..20] of Integer;ããProcedure MkDirCDir(Target : String);ãVarã i,ã count : Integer;ã dir,ã home,ã tempdir : String;ããbeginã { sample directory below to make }ã Dir := Target;ã { add slash at end if not given }ã if Dir[Length(Dir)] <> '\' thenã Dir := Dir + '\';ã { if colon where normally is change to that drive }ã if Dir[2] = ':' thenã ChDir(Copy(Dir, 1, 2))ã elseã { assume current drive (and directory) }ã beginã GetDir(0, Home);ã if Dir[1] <> '\' thenã Dir := Home + '\' + Dirã elseã Dir := Home + Dir;ã end;ãã Count := 0;ã { search directory For slashed and Record them }ã For i := 1 to Length(Dir) doã beginã if Dir[i] = '\' thenã beginã Inc(Count);ã Slash[Count] := i;ã end;ã end;ã { For each step of the way, change to the directory }ã { if get error, assume it doesn't exist - make it }ã { then change to it }ã For i := 2 to Count doã beginã TempDir := Copy(Dir, 1, Slash[i] - 1);ã {$I-}ã ChDir(TempDir);ã if IOResult <> 0 thenã beginã MkDir(TempDir);ã ChDir(TempDir);ã end;ã end;ãend;ããbeginã MkDirCDir('D:\HI.ZZZ\GEEKS\2JKD98');ãend.ã 13 05-28-9313:37ALL SWAG SUPPORT TEAM MAKEDIR2.PAS IMPORT 7 ¦¶Õ {ã Hi Mark, there is a Procedure in Turbo Pascal called MkDir that allowsãyou to create a subdirectory. However if you want source code For a similarãroutine try the following. I just whipped it up so it doesn't contain anyãerror checking, but you could add a simple if else after the Dos call toãcheck the register flags. Anyhow, I hope that this helps ya out.ã}ãProcedure Make_Directory (Directory: String);ã{ parameters: Directory - name of the new directoryã sample-call: Make_Directory('\tools') }ãVarã Regs: Registers;ãbeginã With Regs doã beginã Directory := Directory + chr(0);ã AX := $3900;ã DS := Seg(Directory[1]);ã DX := ofs(Directory[1]);ã MSDos(Dos.Registers(Regs));ã end;ãend;ã 14 08-18-9312:22ALL JOSE ALMEIDA Get a programs directory IMPORT 9 ¦¶ @ { Gets the program directory.ã Part of the Heartware Toolkit v2.00 (HTfile.PAS) for Turbo Pascal.ã Author: Jose Almeida. P.O.Box 4185. 1504 Lisboa Codex. Portugal.ã I can also be reached at RIME network, site ->TIB or #5314.ã Feel completely free to use this source code in any way you want, and, ifã you do, please don't forget to mention my name, and, give me and Swag theã proper credits. }ããFUNCTION Get_Prg_Dir : string;ãã{ DESCRIPTION:ã Gets the program directory.ã SAMPLE CALL:ã St := Get_Prg_Dir;ã RETURNS:ã The program directory, e.g., E:\TP\ã NOTES:ã The program directory is always where the program .EXE file is located.ã This function add a backslash at the end of string. }ããvarã Tmp : string;ããBEGIN { Get_Prg_Dir }ã Tmp := ParamStr(0);ã while (Tmp[Length(Tmp)] <> '\') and (Length(Tmp) <> 0) doã Delete(Tmp,Length(Tmp),1);ã if Tmp = '' thenã Tmp := Get_Cur_Dir;ã Get_Prg_Dir := Tmp;ãEND; { Get_Prg_Dir }ã 15 08-27-9319:58ALL LAWRENCE JOHNSTONE Every Dir in Pascal IMPORT 11 ¦¶üÀ {ãLAWRENCE JOHNSTONEãã³Can someone give me some code (in TP) that recognizes all Sub-dirsã³and Sub-sub-dirs, etc. in drive C and changes into every single oneã³of them one at a time?ã}ããPROGRAM EveryDir;ããUSESã DOSããPROCEDURE ProcessDirs( Path: DOS.PathStr );ãVARã SR : SearchRec;ãBEGINã IF Path[Length(Path)] <> '\' THEN { Make sure last char is '\' }ã Path := Path + '\';ãã { Change to directory specified by Path. Handle root as special case }ã {$I-}ã IF (Length(Path) = 3) AND (Copy(Path, 2, 2) = ':\') THENã ChDir(Path)ã ELSEã ChDir(Copy(Path, 1, Length(Path) - 1);ã IF IOResult <> 0 THENã EXIT; { Quit if we get a DOS error }ã {$I-}ãã { Process all subdirectories of that directory, except for }ã { the '.' and '..' aliases }ã FindFirst(Path + '*.*', Directory, SR);ã WHILE DosError = 0 DOã BEGINã IF ((SR.Attr AND Directory) <> 0) ANDã (SR.Name <> '.') AND (SR.Name <> '..') THENã ProcessDirs( Path + SR.Name );ã FindNext(SR);ã END; { while }ãEND; {ProcessDirs}ããVARã CurDir : DOS.PathStr;ããBEGINã GetDir(3, CurDir); { Get default directory on C }ã ProcessDirs('C:\'); { Process all directories on C }ã ChDir(CurDir); { Restore default directory on C }ãEND.ã 16 08-27-9319:59ALL PER-ERIC LARSSON Find a file anywhere IMPORT 18 ¦¶Vv {ãPER-ERIC LARSSONãã> I've seen some posts asking how to search through directories or how toã> find a File anywhere on the disk, so here's a little Procedure I wroteã> to do it... Give it a whirl and feel free to ask questions...ããThere is a built in trap in the method you describe. I've fallen into it manyãtimes myself so here's a clue. The problem:ãif Your Procedure (that is called once per File) does some processing of theãFile you SHOULD first make a backup copy. personally I rename the originalãFile to .BAK and then take that File as input, writing to a new File With theãoriginal name, perhaps deleting the .bak File if everything works out fine.ãFor most purposes this works fine. But if you do this using findnext to findãthe next File to work With it will Repeat itself til the end of time orãdiskspace.ããTherefore i recommend :ãFirst get all Filenames to work With,ãThen start processing the Files.ã}ããProcedure runFile(ft : String);ãbeginã { Process File here}ãend;ããProcedure RUNALLFileS(FT : String);ãTypeã plista = ^tlista;ã tlista = Recordã namn : String;ã prev : plista;ã end;ãVarã S : SearchRec;ã Dir : DirStr;ã Name : NameStr;ã Ext : ExtStr;ã pp : plista;ããFunction insertbefore(before : plista) : plista;ãVarã p : plista;ãbeginã getmem(p, sizeof(tlista));ã p^.prev := before;ã insertbefore := p;ãend;ããFunction deleteafter(before : plista) : plista;ãbeginã deleteafter := before^.prev;ã freemem(before, sizeof(tlista));ãend;ããbeginã pp := nil;ã FSplit(fT, Dir, Name, Ext);ã FINDFIRST(ft, $3f, S);ã While DosERROR = 0 DOã beginã if (S.ATTR and $18) = 0 thenã beginã pp := insertbefore(pp);ã pp^.namn := dir + s.name;ã end;ã FINDNEXT(S);ã end;ã if pp <> nil thenã Repeatã runFile(pp^.namn);ã pp := deleteafter(pp);ã Until pp = nil;ãend;ããbeginã if paramcount > 0 thenã beginã For filaa := 1 to paramcount doã runALLFileS(paramstr(filaa));ã end;ã Writeln('Klar')ãend.ãã{ãThis is a cutout example from a Program i wroteãIt won't compile but it'll show a way to do it !ã}ã 17 08-27-9321:21ALL JON KENT Setting a files path IMPORT 11 ¦¶ÉY {ãJON KENTããHere's one way to set a File's path "on the fly" using Typed Constants.ã}ããUsesã Dos;ããConstã TestFile1 : String = 'TEST1.DAT';ã TestFile2 : String = 'DATA\TEST2.DAT';ãVarã CurrentPath : String;ããFunction FileStretch(SType : Byte; FileFullName : String) : String;ãVarã P : PathStr;ã D : DirStr;ã N : NameStr;ã E : ExtStr;ãbeginã P := FExpand(FileFullName);ã FSplit(P, D, N, E);ã if D[LENGTH(D)] = '\' thenã D[0] := CHR(PRED(LENGTH(D)));ã Case SType OFã 1 : FileStretch := D;ã 2 : FileStretch := N + E;ã 3 : FileStretch := D + '\' + N;ã 4 : FileStretch := N;ã else FileStretch := '';ã end;ãend;ããbeginã CurrentPath := FileStretch(1,ParamStr(0)); { Get EXE's Path }ã TestFile1 := CurrentPath + '\' + TestFile1; { Set DAT Paths }ã TestFile2 := CurrentPath + '\' + TestFile2;ãã {...}ããend.ã{-----------------------------}ãã{ if CurrentPath = C:\WORK thenãã TestFile1 = C:\WORK\TEST1.DATã TestFile2 = C:\WORK\DATA\TEST2.DATãã This works Really well when you want to store a Program's configurationã File or data Files in the same directory as the Program regardless itsã location.ã} 18 09-26-9309:10ALL MARTIN RICHARDSON Check for Directory IMPORT 7 ¦¶æÝ ã{*****************************************************************************ã * Function ...... IsDir()ã * Purpose ....... To check for the existance of a directoryã * Parameters .... Dir Dir to check forã * Returns ....... TRUE if Dir existsã * Notes ......... Noneã * Author ........ Martin Richardsonã * Date .......... May 13, 1992ã *****************************************************************************}ãFUNCTION IsDir( Dir: STRING ) : BOOLEAN;ãVARã fHandle: FILE;ã wAttr: WORD;ãBEGINã WHILE Dir[LENGTH(Dir)] = '\' DO DEC( Dir[0] );ã Dir := Dir + '\.';ã ASSIGN( fHandle, Dir );ã GETFATTR( fHandle, wAttr );ã IsDir := ( (wAttr AND DIRECTORY) = DIRECTORY );ãEND;ãã 19 11-02-9306:08ALL HERBERT ZARB Change File Attr IMPORT 7 ¦¶Ðé { Updated FILES.SWG on November 2, 1993 }ãã{ãHerbert Zarb ãã This simple Program changes the attribute of the File or directory fromã hidden to archive or vice-versa...ã}ããProgram hide_unhide;ã{ Accepts two command line parameters :ã 1st parameter can be either +h (hide) or -h(unhide).ã 2nd parameter must be the full path }ãUsesã Dos;ããConstã bell = #07;ã hidden = $02;ã archive = $20;ããVarã f : File;ããbeginã if paramcount >= 2 thenã beginã Assign(f, paramstr(2));ã if paramstr(1) = '+h' thenã SetFAttr(f, hidden)ã elseã if paramstr(1) = '-h' thenã SetFAttr(f, Archive)ã elseã Write(bell);ã endã elseã Write(bell);ãend.ã 20 11-02-9306:08ALL TIMO SALMI Another Change File Attr IMPORT 11 ¦¶Ï¨ { Updated FILES.SWG on November 2, 1993 }ãã{ã[email protected] (Timo Salmi)ãã Q: How can one hide (or unhide) a directory using a TP Program?ãã A: SetFAttr which first comes to mind cannot be used For this.ãInstead interrupt Programming is required. Here is the code.ãIncidentally, since MsDos 5.0 the attrib command can be used to hideãand unhide directories.ã(* Hide a directory. Before using it would be prudent to checkã that the directory exists, and that it is a directory.ã With a contribution from Jan Nielsen [email protected]ã Based on information from Duncan (1986), p. 410 *)ã}ãProcedure HIDE(dirname : String);ãVarã regs : Registers;ãbeginã FillChar(regs, SizeOf(regs), 0); { standard precaution }ã dirname := dirname + #0; { requires ASCII Strings }ã regs.ah := $43; { Function }ã regs.al := $01; { subFunction }ã regs.ds := Seg(dirname[1]); { point to the name }ã regs.dx := Ofs(dirname[1]);ã regs.cx := 2; { set bit 1 on } { to unhide set regs.cx := 0 }ã Intr ($21, regs); { call the interrupt }ã if regs.Flags and FCarry <> 0 then { were we successful }ã Writeln('Failed to hide');ãend;ã 21 11-02-9310:27ALL DAVID DRZYZGA Multiple Dir Picks IMPORT 22 ¦¶òÀ {ãDAVID DRZYZGAãã> And I can't seem to get the OpDir system to work With multiple Files, orã> at least I can't get the "tagging" Function to work.ããHere's a somewhat stripped snipit of code from one of my apps that will giveãyou a clear example of how to use the multiple pick Function of the DirListãObject:ã}ããProgram DirTest;ãã{$I OPDEFINE.INC}ããUsesã Dos,ã OpRoot,ã OpConst,ã OpString,ã OpCrt,ã OpCmd,ã OpFrame,ã OpWindow,ã OpPick,ã OpDir,ã OpColor;ããConstã SliderChar = '²';ã ScrollBarChar = '°';ã Frame1 : FrameArray = 'ÚÀ¿ÙÄij³';ã Counter : Word = 1;ããVarã Dir : DirList;ã Finished : Boolean;ã SelectedItem : Word;ã DirWinOpts : LongInt;ã I : Integer;ããProcedure ProcessFile(FileName : String);ãbeginã {This is where you would process each of the tagged Files}ãend;ããbeginã DirWinOpts := DefWindowOptions+wBordered;ã if not Dir.InitCustom(20, 4, 50, 19, {Window coordinates}ã DefaultColorSet, {ColorSet}ã DirWinOpts, {Window options}ã MaxAvail, {Heap space For Files}ã PickVertical, {Pick orientation}ã MultipleFile) {Command handler}ã thenã beginã WriteLn('Failed to Init DirList, Status = ', InitStatus);ã Halt;ã end;ãã {Set desired DirList features}ã With Dir doã beginã wFrame.AddShadow(shBR, shSeeThru);ã wFrame.AddCustomScrollBar(frRR, 0, MaxLongInt, 1, 1, SliderChar,ã ScrollBarChar, DefaultColorSet);ãã SetSelectMarker(#251' ', '');ã SetPosLimits(1, 1, ScreenWidth, ScreenHeight-1);ã SetPadSize(1, 1);ã diOptionsOn(diOptimizeSize);ã AddMaskHeader(True, 1, 30, heTC);ã SetSortOrder(SortDirName);ã SetNameSizeTimeFormat('', 'Mm/dd/yy', 'Hh:mmt');ã SetMask('*.*', AnyFile);ã end;ãã {: process selected list}ã PickCommands.AddCommand(ccUser0, 1, $1900, 0);ãã {Pick Files}ã Finished := False;ã Repeatã Dir.Process;ã Case Dir.GetLastCommand ofã ccSelect : ;ã ccError : ;ã ccUser0 :ã beginã Counter := 1;ã if Dir.GetSelectedCount > 0 thenã beginã Dir.InitSequence(SelectedItem);ã While Dir.HaveSelected(SelectedItem) doã beginã ProcessFile(Dir.GetMultiPath(SelectedItem));ã Inc(Counter);ã Dir.NextSelected(SelectedItem);ã Dir.ResetList;ã end;ã endã end;ãã ccQuit : Finished := True;ã end;ã Until Finished;ãã Dir.Erase;ã ClrScr;ã Dir.Done;ãend.ã 22 01-27-9413:32ALL ROBERT ROTHENBURG Files Wildcard Matching IMPORT 99 ¦¶¼ (* -------------------------------------------------------------- *)ã(* FileSpec.PAS v1.0a by Robert Walking-Owl November 1993 *)ã(* -------------------------------------------------------------- *)ãã{ Things to add... }ã{ - have # and $ be symbols for ASCII chars in dec/hex? }ãã(* Buggie Things: *)ã(* - anti-sets don't work with variable lenght sets, since they *)ã(* end with the first character NOT in the set... *)ãã{$F+}ããunit FileSpec;ããinterfaceããuses Dos;ããconstã DosNameLen = 12; (* Maximum Length of DOS filenames *)ã UnixNameLen = 32; (* Maximum Length of Unix Filenames *)ãã MaxWildArgs = 32; (* Maximum number of wildcard arguments *)ã MaxNameLen = 127;ãã fCaseSensitive = $01; (* Case Sensitive Flag *)ã fExtendedWilds = $02; (* Use extented wildcard forms (not,sets *)ã fUndocumented = $80; (* Use DOS 'undocumented' filespecs *)ããtypeã SpecList = array [1..MaxWildArgs] of recordã Name: string[ MaxNameLen ]; (* or use DOS ParamStr? *)ã Truth: Booleanã end;ã PWildCard = ^TWildCard;ã TWildCard = objectã privateã FileSpecs: SpecList; (* List of filespecs *)ã NumNegs, (* Number of "not" specs *)ã FSpCount: word; (* Total number of specs *)ã function StripQuotes( x: string ): string;ã procedure FileSplit(Path: string;ã var Dir,Name,Ext: string);ã publicã PathChar, (* path seperation char *)ã NotChar, (* "not" char - init '~' *)ã QuoteChar: Char; (* quote char - init '"' *)ã Flags, (* Mode flags ... *)ã FileNameLen: Byte; (* MaxLength of FileNames *)ã constructor Init;ã procedure AddSpec( name: string);ã function FitSpec( name: string): Boolean;ã destructor Done;ã (* Methods to RemoveSpec() or ChangeSpec() aren't added *)ã (* since for most applications they seem unnecessary. *)ã (* An IsValid() spec to see if a specification is valid *)ã (* syntax is also unnecessary, since no harm is done, *)ã (* and DOS and Unix ignore them anyway .... *)ã end;ãããimplementationããprocedure UpCaseStr( var S: string); assembler;ãasmã PUSH DSã LDS SI,Sã MOV AL,BYTE PTR DS:[SI]ã XOR CX,CXã MOV CL,ALã@STRINGLOOP: INC SIã MOV AL,BYTE PTR DS:[SI]ã CMP AL,'a'ã JB @NOTLOCASEã CMP AL,'z'ã JA @NOTLOCASEã SUB AL,32ã MOV BYTE PTR DS:[SI],ALã@NOTLOCASE: LOOP @STRINGLOOPã POP DSãend;ãããconstructor TWildCard.Init;ãbeginã FSpCount := 0;ã NumNegs := 0;ã NotChar := '~';ã QuoteChar := '"';ã Flags := fExtendedWilds or fUndocumented;ã FileNameLen := DosNameLen;ã PathChar := '\';ãend;ããdestructor TWildCard.Done;ãbeginã FSpCount := 0ãend;ããfunction TWildCard.StripQuotes( x: string ): string;ãbeginã if x<>''ã then if (x[1]=QuoteChar) and (x[length(x)]=QuoteChar)ã then StripQuotes := Copy(x,2,Length(x)-2)ã else StripQuotes := xãend;ããprocedure TWildCard.AddSpec( Name: string);ãvarã Truth: Boolean;ãbeginã if Name <> '' then beginã Truth := True;ã if (Flags and fExtendedWilds)<>0ã then beginã if Name[1]=NotCharã then beginã inc(NumNegs);ã Truth := False;ã Name := Copy( Name , 2, Pred(Length(Name)) );ã end;ã Name := StripQuotes( Name );ã end;ã if (FSpCount<>MaxWildArgs) and (Name<>'')ã then beginã inc( FSpCount );ã FileSpecs[ FSpCount ].Name := Name;ã FileSpecs[ FSpCount ].Truth := Truthã end;ã endãend;ããprocedure TWildCard.FileSplit(Path: string; var Dir,Name,Ext: string);ãvarã i,p,e: byte;ã InSet: Boolean;ãbeginã p:=0;ã if (Flags and fCaseSensitive)=0ã then UpCaseStr(Path);ã for i:=1 to length(Path) do if Path[i]=PathChar then p:=i;ã i:=Length(Path);ã InSet := False;ã e := succ(length(Path));ã repeatã if not Insetã then case Path[i] ofã '.': e := i;ã ']',ã '}',ã ')': InSet := True;ã endã else if Path[i] in ['[','{','('] then InSet := False;ã dec(i);ã until i=0;ã if p=0ã then Dir := ''ã else Dir := Copy(Path,1,p);ã Name := Copy(Path,Succ(p),pred(e-p));ã if e<=length(Path)ã then Ext := Copy(Path,e,succ(Length(Path)-e))ã else Ext := '';ãend;ããfunction TWildCard.FitSpec( name: string): Boolean;ããprocedure Puff(var x: string); (* Pad filename with spaces *)ãbeginã while length(x)=FileNameLen) or (s[k]=EndSet) or (s[k]<>',');ã u := '';ã if (kEndSet) then beginã repeatã u := u + s[k];ã inc(k);ã until (k>=FileNameLen) or (s[k]=EndSet) or (s[k]=',');ã if u<>'' then beginã if u[1]=NotCharã then beginã A := True;ã u := Copy(u,2,pred(length(u)));ã end;ã u := StripQuotes(u);ã if (length(u)=3) and (u[2]='-')ã then beginã for c := u[1] to u[3]ã do if A then b := b+[ c ]ã else x := x+[ c ]ã endã else beginã for i:=1 to length(u)ã do if A then b := b+[ u[i] ]ã else x:=x+[ u[i] ];ã endã end;ã end;ãend;ããfunction Match(n,s: string): Boolean; (* Does a field match? *)ãvar i,j,k: byte;ã c: char;ã T: Boolean;ã Scrap: string;ãbeginã i := 1; (* index of filespec *)ã j := 1; (* index of name *)ã T := True;ã Puff(n);ã Puff(s);ã repeatã if s[i]='*' then i:=FileNameLen (* Abort *)ã elseã case s[i] ofã '(' : if ((Flags and fExtendedWilds)<>0) then beginã Scrap := '';ã inc(i);ã repeatã Scrap := Scrap + s[i];ã inc(i);ã until (i>=FileNameLen) or (s[i]=')');ã Scrap := StripQuotes(Scrap);ã if Pos(Scrap,Copy(n,j,Length(n)))=0ã then T := False;ã end;ã '[' : if ((Flags and fExtendedWilds)<>0) then beginã x := []; b := [];ã k:=succ(i);ã repeatã GetSet(s,']',k);ã until (k>=FileNameLen) or (s[k]=']');ã i := k;ã if x=[] then FillChar(x,SizeOf(x),#255);ã x := x-b;ã if not (n[j] in x) then T := False;ã end;ã '{' : if ((Flags and fExtendedWilds)<>0) then beginã x := []; b := [];ã k:=succ(i);ã repeatã GetSet(s,'}',k);ã until (k>=FileNameLen) or (s[k]='}');ã i := succ(k);ã if x=[] then FillChar(x,SizeOf(x),#255);ã x := x-b;ã while (n[j] in x) and (j<=FileNameLen)ã do inc(j);ã end;ã else if T and (s[i]<>'?')ã then if s[i]<>n[j] then T := False;ã end;ã inc(i);ã inc(j);ã until (not T) or (s[i]='*') or (i>FileNameLen) or (j>FileNameLen);ã Match := T;ãend;ããvar i,ã NumMatches : byte;ã dn,de,nn,ne,sn,se: string;ã Negate : Boolean;ãbeginã Negate := False;ã if FSpCount=0 then NumMatches := 1ã else beginã NumMatches := 0;ã for i:=1 to FSpCountã do beginã FileSplit(name,dn,nn,ne);ã FileSplit(FileSpecs[i].Name,de,sn,se);ã if ne='' then ne:='. ';ã if (Flags and fUnDocumented)<>0 then beginã if sn='' then sn:='*';ã if se='' then se:='.*';ã if dn='' then dn:='*';ã if de='' then de:='*';ã end;ã if (Match(dn,de) and Match(nn,sn) and Match(ne,se))ã then beginã inc(NumMatches);ã if not FileSpecs[i].Truthã then Negate := True;ã end;ã end;ã end;ã if (NumNegs=FSpCount) and (NumMatches=0)ã then FitSpec := Trueã else FitSpec := (NumMatches<>0) xor Negate;ãend;ãããend.ãã{--------------------- DEMO ------------------------- }ãã(* Demo program to "test" the FileSpec unit *)ã(* Checks to see if file matches filespec... good for testing/debugging *)ã(* the FileSpec object/unit, as well as learning the syntax of FileSpec *)ããprogram FileSpec_Test(input, output);ã uses FileSpec;ãvar p, (* User-entered "filespec" *)ã d: String; (* Filename to "test" *)ã FS: TWildCard; (* FileSpec Object *)ãbeginã FS.Init; (* Initialize *)ã WriteLn;ã Write('Enter filespec -> '); ReadLN(p); (* Get filespec... *)ã FS.AddSpec(p); (* ... Add Spec to list ... *)ã Write('Enter file -----> '); ReadLN(d); (* ... Get Filename ... *)ã if FS.FitSpec(d) (* Is the file in the list? *)ã then WriteLN('The files match.')ã else WriteLN('The files don''t match.');ã FS.Done; (* Done... clean up etc. *)ãend.ãããFileSpec v1.0aã--------------ãã"FileSpec" is a public domain Turbo Pascal unit that gives you advanced,ãUnix-like filespecs and wildcard-matching capabilities for your software.ãThis version should be compatible with Turbo Pascal v5.5 upwards (sinceãit uses OOP).ããThe advantage is that you can check to see if a filename is within theãspecs a user has given--even multiple filespecs; thus utilities likeãfile-finders or archive-viewers can have multiple file-search specif-ãications.ããTo use, first initialize the TWildCard object (.Init).ããYou then use .AddSpec() to add the wildcards (e.g. user-specified) to theãlist; and use .FitSpec() to see if a filename "fits" in that list.ããWhen done, use the .Done destructor. (Check your TPascal manual if you doãnot understand how to use objects).ãã"FileSpec" supports standard DOS wilcards (* and ?); also supported are theãundocumented DOS wildcards (eg. FILENAME = FILENAME.* and .EXT = *.EXT).ããHowever, "FileSpec" supports many extended features which can make a programãmany times more powerful. Filenames or wildcards can be in quotes (eg. "*.*"ãis equivalent to *.*).ããAlso supported are "not" (or "but") wildcards using the ~ character. Thusãa hypothetical directory-lister with the argument ~*.TXT would list allãfiles _except_ those that match *.TXT.ããFixed and variable length "sets" are also supported:ãã[a-m]*.* <- Any files beginning with letters A-Mã[a-z,~ux]*.* <- Any files beginning with a any letter except X or Uã*.?[~q]? <- Any files except those that match *.?Q?ãfoo[abc]*.* <- Files of FOO?*.* where '?' is A,B or Cãfoo["abc"]*.* <- Same as above.ãfoo[a-c]*.* <- Same as above.ãtest{0-9}.* <- Files of TEST0.* through TEST9999.*ãx{}z.* <- Filenames beginning with X and ending with Zãx{0123456789}z.* <- Same as above, only with numbers between X and Z.ã("read")*.* <- Filenames that contain the text "READ"ããIf this seems confusing, use the FS-TEST.PAS program included with thisãarchive to experiment and learn the syntax used by "FileSpec".ããPlaying around with the included demos (LS.PAS, a directory lister; andãXFIND, a file-finder) will also give you an idea how to use the FileSpecsãunit.ããOne Note: if you use the FileSpec unit with your software, please let usersãknow about it in the documentation, so that they know they can take fullãadvantage of the added features.ãã 23 01-27-9413:32ALL ROBERT ROTHENBURG DOS Files Listing IMPORT 8 ¦¶â program ListFiles(input,output);ã uses Dos,ã FileSpec;ããvarã FS: TWildCard;ããprocedure WriteName(Name: string; Attr: word);ãvar T: String;ãbeginã if Attr=Directoryã then Name := '['+Name+']';ã Name := Name + ' '; (* 16 spaces *)ã Write( Copy(Name,1,16) );ãend;ããprocedure ListFiles;ãvarã Search: SearchRec;ãbeginã FindFirst('*.*',AnyFile,Search);ã if DosError<>18 then beginã if FS.FitSpec(Search.Name)ã then WriteName(Search.Name,Search.Attr);ã repeatã FindNext(Search);ã if DosError<>18ã then if FS.FitSpec(Search.Name)ã then WriteName(Search.Name,Search.Attr);ã until DosError = 18;ã end;ãend;ããvarã i: Byte;ãbeginã FS.Init;ã for i := 1 to ParamCount do FS.AddSpec(ParamStr(i));ã ListFiles;ã FS.Done;ã WriteLn;ãend.ã 24 01-27-9413:34ALL ROBERT ROTHENBURG File Finder IMPORT 13 ¦¶Å¹ ãprogram XFind(input,output);ã uses Dos,ã FileSpec;ããvarã FS: TWildCard;ãããprocedure WriteSpec(Name: string);ãbeginã Name := FExpand(Name);ã WriteLn(Name);ãend;ããprocedure FindFiles(Dir: String);ãvarã Search: SearchRec;ã CurDir: String;ã DirList: array [1..128] of string[12];ã i,ã DirNum: Byte;ãbeginã CurDir := FExpand('.');ã if (Dir<>'.') and (Dir<>'..') then beginã ChDir(FExpand(Dir));ã DirNum := 0;ã FindFirst('*.*',AnyFile,Search);ã if DosError<>18 then beginã if Search.Attr=Directoryã then beginã inc(DirNum);ã DirList[ DirNum ] := Search.Name;ã endã else if FS.FitSpec(Search.Name)ã then WriteSpec(Search.Name);ã repeatã FindNext(Search);ã if DosError<>18ã then if Search.Attr=Directoryã then beginã inc(DirNum);ã DirList[ DirNum ] := Search.Name;ã endã else if FS.FitSpec(Search.Name)ã then WriteSpec(Search.Name);ã until DosError = 18;ã end;ã if DirNum<>0ã then for i := 1 to DirNum do FindFiles(DirList[i]);ã ChDir(CurDir);ã end;ãend;ããvarã i: Byte;ãbeginã if ParamCount = 0ã then WriteLn('Usage: XFIND file1 [file2 file3 ... ]')ã else beginã FS.Init;ã for i := 1 to ParamCount do FS.AddSpec(ParamStr(i));ã FindFiles('\');ã FS.Done;ã end;ãend.ã 25 02-03-9416:18ALL EDDY THILLEMAN Recursive Directory Roam IMPORT 21 ¦¶õ« ã{$M 65520,0,655360}ããUses DOS;ããTypeã String12 = string[12];ããConstã FAttr : word = $23; { readonly-, hidden-, archive attributen }ããVarã CurDir : PathStr;ã StartDir: DirStr;ã FMask : String12;ã subdirs : boolean;ãããFunction UpStr(const s:string):string; assembler;ã{ by Brain Pape, found in the SWAG collection }ãasmã push dsã lds si,sã les di,@resultã lodsb { load and store length of string }ã stosbã xor ch,chã mov cl,alã @upperLoop:ã lodsbã cmp al,'a'ã jb #contã cmp al,'z'ã ja #contã sub al,' 'ã #cont:ã stosbã loop @UpperLoopã pop dsãend; { UpStr }ãããProcedure ParseCmdLine;ãvarã t : byte;ã cmd: string;ãbeginã for t := 2 to ParamCount do beginã cmd := UpStr(Copy(ParamStr(t),1,2));ã if cmd = '/S' then subdirs := true;ã end;ãend;ãããFunction NoTrailingBackslash (path : String) : String;ãbeginã if (length(path) > 3) and (path[length(path)] = '\') thenã path[0] := chr(length(path) - 1);ã NoTrailingBackslash := path;ãend;ãããProcedure PathAnalyze (P: PathStr; Var D: DirStr; Var Name: String12);ãVarã N: NameStr;ã E: ExtStr;ããbeginã FSplit(P, D, N, E);ã Name := N + E;ãend;ãããProcedure Process (var SR: SearchRec);ã{ here you can put anything you want to do in each directory with each file }ãbeginã writeln(FExpand(SR.Name));ãend;ãããProcedure FindFiles;ãvarã FR : SearchRec;ããbeginã FindFirst(FMask, FAttr, FR);ã while DosError = 0 doã beginã Process(FR);ã FindNext(FR);ã end;ãend;ããã{$S+}ãProcedure AllDirs;ã{ recursively roam through subdirectories }ãvarã DR : SearchRec;ããbeginã FindFirst('*.*', Directory, DR);ã while DosError = 0 do beginã if DR.Attr and Directory = Directory then beginã if ((DR.Name <> '.') and (DR.Name <> '..')) then beginã ChDir(DR.Name);ã AllDirs; { Recursion!!! }ã ChDir('..');ã endã end;ã FindNext(DR);ã end;ã FindFiles;ãend;ã{$S-}ãããbeginã subdirs := false;ã GetDir (0, CurDir);ã if ParamCount > 1 then ParseCmdLine;ãã PathAnalyze (FExpand(ParamStr(1)), StartDir, FMask);ã if Length (StartDir) > 0 then ChDir (NoTrailingBackslash(StartDir));ã if IOResult <> 0 thenã beginã Writeln('Cannot find directory.');ã Halt(1);ã end;ã if Length (FMask) = 0 then FMask := '*.*';ã if subdirs then AllDirs else FindFiles;ã ChDir (CurDir);ãend.ãã{--------------- cut here -------------------}ããyou can give an optional filemask to see only files which meet thisãfilemask.ã 26 02-15-9408:40ALL DANIEL BRONSTEIN Qualified path/file IMPORT 20 ¦¶
{******************************************************************ã * Create a function for returning a fully qualified path/file *ã * string, with the *'s replaced by the appropriate number of ?'s.*ã * *ã * (C) Daniel A. Bronstein, Michigan State University, 1991. *ã * May be used freely with acknowledgement. *ã *****************************************************************}ããunit qualify;ããInterfaceãuses dos; {for pathstr definition}ããfunction fqualify(var ps:pathstr):pathstr;ããImplementationãã{$F+} {Far call so loading of the variable is simplified for asm.}ãfunction fqualify(var ps:pathstr):pathstr;ãbeginã asmã push ds {Save DS, else will crash after exit}ã push si {and just to be safe, save SI too.}ã lds si,ps {Load address of pathstring,}ã xor ax,ax {clear AX,}ã cld {set direction flag and}ã lodsb {get length byte, incrementing SI.}ã mov bx,ax {Move length to BX and add}ã mov byte ptr[si+bx],0 {a #0 to end to create ASCIIZ string.}ã les di,@result {Load address of the output string}ã mov bx,di {and save it in BX.}ã inc di {Point past length byte of result}ã mov ah,60h {and call DOS function 60h.}ã int 21hã jnc @ok {If no carry then ok, else return}ã mov byte ptr[es:bx],0 {a 0 length string.}ã jmp @xitã@ok:ã xor cx,cx {Clear CX and}ã@0loop:ã inc di {loop until find end of returned}ã inc cx {ASCIIZ string.}ã cmp byte ptr[es:di],0 {**Note that on 286 & 386 inc/cmp is faster}ã jne @0loop {**than CMPSB, so used here.}ã mov byte ptr[es:bx],cl {Set the length byte of the result.}ã@xit:ã pop si {Restore SI and}ã pop ds {DS, then}ã end; {exit.}ãend;ã{$F-}ããbeginãend.ãã{ ================================== DEMO ============================}ããPROGRAM Qualtest;ããUSES DOS, Qualify;ããVARã MyString, YourString : PathStr;ããBEGINã MyString := 'Foo*.*';ã YourString := FQualify(MyString);ã Writeln(YourString);ã Readln;ããEND. 27 02-15-9408:40ALL MATTHEW PALCIC DOS Directory Routines IMPORT 90 ¦¶ ã{ Updated DIRS.SWG on February 15, 1994 }ããUnit PDir;ãã(*ãã Palcic Directory Routinesã Copyright (C) 1989, Matthew J. Palcicã Requires Turbo Pascal 5.5 or higherãã v1.0, 18 Aug 89 - Original release.ãã*)ãããINTERFACEããuses Dos,Objects;ãã(*------------------------------------------------------------------------*)ããTYPEãã AttrType = Byte;ã FileStr = String[12];ãã BaseEntryPtr = ^BaseEntry;ã BaseEntry = object(Node)ã Attr: AttrType;ã Time: Longint;ã Size: Longint;ã Name: FileStr;ã constructor Init;ã destructor Done; virtual;ã procedure ConvertRec(S:SearchRec);ã function FileName: FileStr; virtual;ã function FileExt: ExtStr; virtual;ã function FullName: PathStr; virtual;ã function FileTime: Longint; virtual;ã function FileAttr: AttrType; virtual;ã function FileSize: Longint; virtual;ã function IsDirectory: Boolean;ã constructor Load(var S: Stream);ã procedure Store(var S: Stream); virtual;ã end;ãã FileEntryPtr = ^FileEntry;ã FileEntry = object(BaseEntry)ã constructor Init;ã destructor Done; virtual;ã procedure ForceExt(E:ExtStr);ã procedure ChangeName(P:PathStr); virtual;ã (* Change the name in memory *)ã procedure ChangePath(P:PathStr); virtual;ã procedure ChangeTime(T:Longint); virtual;ã procedure ChangeAttr(A:AttrType); virtual;ã procedure Erase; virtual;ã function Rename(NewName:PathStr): Boolean; virtual;ã (* Physically rename file on disk, returns False if Rename fails *)ã function ResetTime: Boolean;ã function ResetAttr: Boolean;ã function SetTime(T:Longint): Boolean; virtual;ã function SetAttr(A:AttrType): Boolean; virtual;ã constructor Load(var S: Stream);ã procedure Store(var S: Stream); virtual;ã end;ãã DirEntryPtr = ^DirEntry;ã DirEntry = object(FileEntry)ã DirEntries: List;ã constructor Init;ã constructor Clear;ã destructor Done; virtual;ã procedure FindFiles(FileSpec: FileStr; Attrib: AttrType);ã procedure FindDirectories(FileSpec: FileStr; Attrib: AttrType);ã constructor Load(var S: Stream);ã procedure Store(var S: Stream); virtual;ã end;ãã DirStream = object(DosStream)ã procedure RegisterTypes; virtual;ã end;ããfunction ExtensionPos(FName : PathStr): Word;ãfunction CurDir: PathStr;ãfunction ReadString(var S: Stream): String;ãprocedure WriteString(var S: Stream; Str: String);ãã(*------------------------------------------------------------------------*)ããIMPLEMENTATIONãã (*--------------------------------------------------------------------*)ã (* Methods for BaseEntry *)ã (*--------------------------------------------------------------------*)ãã constructor BaseEntry.Init;ã beginã end;ãã destructor BaseEntry.Done;ã beginã end;ãã procedure BaseEntry.ConvertRec;ã beginã Name := S.Name;ã Size := S.Size;ã Time := S.Time;ã Attr := S.Attr;ã end;ãã function BaseEntry.FileName;ã beginã FileName := Name;ã end;ãã function BaseEntry.FullName;ã beginã FullName := Name;ã end;ãã function BaseEntry.FileExt;ã varã ep: word;ã beginã ep := ExtensionPos(Name);ã if ep > 0 thenã FileExt := Copy(Name, Succ(ep), 3)ã elseã FileExt[0] := #0;ã end;ããã function BaseEntry.FileAttr;ã beginã FileAttr := Attr;ã end;ãã function BaseEntry.FileSize;ã beginã FileSize := Size;ã end;ãã function BaseEntry.FileTime;ã beginã FileTime := Time;ã end;ãã function BaseEntry.IsDirectory;ã beginã IsDirectory := (FileAttr and Dos.Directory) = Dos.Directory;ã end;ãã constructor BaseEntry.Load;ã beginã S.Read(Attr,SizeOf(Attr));ã S.Read(Time,SizeOf(Time));ã S.Read(Size,SizeOf(Size));ã Name := ReadString(S);ã end;ãã procedure BaseEntry.Store;ã beginã S.Write(Attr,SizeOf(Attr));ã S.Write(Time,SizeOf(Time));ã S.Write(Size,SizeOf(Size));ã WriteString(S,Name);ã end;ãã (*--------------------------------------------------------------------*)ã (* Methods for FileEntry *)ã (*--------------------------------------------------------------------*)ãã constructor FileEntry.Init;ã beginã BaseEntry.Init; (* Call ancestor's Init *)ã Name := '';ã Size := 0;ã Time := $210000; (* Jan. 1 1980, 12:00a *)ã Attr := $00; (* ReadOnly = $01;ã Hidden = $02;ã SysFile = $04;ã VolumeID = $08;ã Directory = $10;ã Archive = $20;ã AnyFile = $3F; *)ã end;ãã destructor FileEntry.Done;ã beginã BaseEntry.Done;ã end;ãã function FileEntry.Rename;ã varã F: File;ã beginã Assign(F,FullName);ã System.Rename(F,NewName); (* Explicit call to 'System.Rename' avoidã calling method 'FileEntry.Rename' *)ã if IOResult = 0 thenã beginã ChangePath(NewName);ã Rename := True;ã endã elseã Rename := False;ã end;ãã procedure FileEntry.ForceExt;ã varã ep: Word;ã TempBool: Boolean;ã beginã ep := ExtensionPos(FullName);ã if ep > 0 thenã TempBool := Rename(Concat(Copy(FullName, 1, ep),FileExt))ã elseã TempBool := Rename(Concat(FullName,'.',FileExt));ã end;ãã procedure FileEntry.ChangeName;ã beginã Name := P;ã end;ãã procedure FileEntry.ChangePath;ã beginã Name := P; (* FileEntry object does not handle path *)ã end;ãã procedure FileEntry.ChangeTime;ã beginã Time := T;ã end;ãã procedure FileEntry.ChangeAttr;ã beginã Attr := A;ã end;ãã procedure FileEntry.Erase;ã varã F:File;ã beginã Assign(F,FullName);ã Reset(F);ã System.Erase(F); (* Remove ambiguity about 'Erase' call *)ã Close(F);ã end;ãã function FileEntry.ResetTime;ã varã F:File;ã beginã Assign(F,FullName);ã Reset(F);ã SetFTime(F,FileTime);ã ResetTime := IOResult = 0;ã Close(F);ã end;ãã function FileEntry.SetTime;ã varã F:File;ã beginã Assign(F,FullName);ã Reset(F);ã SetFTime(F,T);ã SetTime := IOResult = 0;ã Close(F);ã end;ãã function FileEntry.ResetAttr;ã varã F:File;ã beginã Assign(F,FullName);ã SetFAttr(F,FileAttr);ã ResetAttr := IOResult = 0;ã end;ãã function FileEntry.SetAttr;ã varã F:File;ã beginã ChangeAttr(A);ã SetAttr := ResetAttr;ã end;ãã constructor FileEntry.Load;ã beginã BaseEntry.Load(S);ã end;ãã procedure FileEntry.Store;ã beginã BaseEntry.Store(S);ã end;ãã (*--------------------------------------------------------------------*)ã (* Methods for DirEntry *)ã (*--------------------------------------------------------------------*)ãã constructor DirEntry.Init;ã varã TempNode: Node;ã beginã FileEntry.Init;ã DirEntries.Delete;ã end;ãã destructor DirEntry.Done;ã beginã DirEntries.Delete;ã FileEntry.Done;ã end;ãã constructor DirEntry.Clear;ã beginã DirEntries.Clear;ã Init;ã end;ãã procedure DirEntry.FindFiles;ã varã DirInfo: SearchRec;ã TempFile: FileEntryPtr;ã beginã FindFirst(FileSpec,Attrib,DirInfo);ã while (DosError = 0) doã beginã TempFile := New(FileEntryPtr,Init);ã TempFile^.ConvertRec(DirInfo);ã DirEntries.Append(TempFile);ã FindNext(DirInfo);ã end;ã end;ãã procedure DirEntry.FindDirectories;ã varã DirInfo: SearchRec;ã TempDir: DirEntryPtr;ã beginãã if FileSpec <> '' thenã FindFiles(FileSpec,Attrib and not Dos.Directory);ãã FindFirst('*.*',Dos.Directory,DirInfo);ã while (DosError = 0) doã beginã if (DirInfo.Name[1] <> '.') andã ((DirInfo.Attr and Dos.Directory) = Dos.Directory) thenã { if first character is '.' then name is either '.' or '..' }ã beginã TempDir := New(DirEntryPtr,Clear);ã TempDir^.ConvertRec(DirInfo);ã DirEntries.Append(TempDir);ã end;ã FindNext(DirInfo);ã end;ãã TempDir := DirEntryPtr(DirEntries.First);ã while TempDir <> nil doã beginã if TempDir^.IsDirectory thenã beginã ChDir(TempDir^.FileName);ã TempDir^.FindDirectories(FileSpec,Attrib);ã ChDir('..');ã end;ã TempDir := DirEntryPtr(DirEntries.Next(TempDir));ã end;ã end;ãã constructor DirEntry.Load;ã beginã FileEntry.Load(S);ã DirEntries.Load(S);ã end;ãã procedure DirEntry.Store;ã beginã FileEntry.Store(S);ã DirEntries.Store(S);ã end;ãã (*--------------------------------------------------------------------*)ã (* Methods for DirStream *)ã (*--------------------------------------------------------------------*)ãã procedure DirStream.RegisterTypes;ã beginã DosStream.RegisterTypes;ã Register(TypeOf(BaseEntry),@BaseEntry.Store,@BaseEntry.Load);ã Register(TypeOf(FileEntry),@FileEntry.Store,@FileEntry.Load);ã Register(TypeOf(DirEntry),@DirEntry.Store,@DirEntry.Load);ã end;ãã(*---------------------------------------------------------------------*)ã(* Miscellaneous Unit procedures and functions *)ã(*---------------------------------------------------------------------*)ããfunction ExtensionPos;ã varã Index: Word;ã beginã Index := Length(FName)+1;ã repeatã dec(Index);ã until (FName[Index] = '.') OR (Index = 0);ã IF (Pos('\', Copy(FName, Succ(Index), SizeOf(FName))) <> 0) THEN Index := 0;ã ExtensionPos := Index;ã end;ããfunction CurDir;ã varã P: PathStr;ã beginã GetDir(0,P); { 0 = Current drive }ã CurDir := P;ã end;ããfunction ReadString;ã varã T: String;ã L: Byte;ãã beginã S.Read(L, 1);ã T[0] := Chr(L);ã S.Read(T[1], L);ã IF S.Status = 0 thenã ReadString := Tã elseã ReadString := '';ã end;ããprocedure WriteString;ã beginã S.Write(Str, Length(Str) + 1);ã end;ãã(* No initialization code *)ãend.ãã{=============================== DEMO ============================ }ããprogram PDTest;ããuses Objects,PDir,Dos;ããvarã DP: DirEntryPtr;ã St: DirStream;ã Orig: PathStr;ããprocedure ProcessDir(D: DirEntryPtr; DirName: PathStr);ã varã DirPtr : DirEntryPtr;ã beginã DirPtr := DirEntryPtr(D^.DirEntries.First);ã while DirPtr <> nil doã beginã if DirPtr^.IsDirectory thenã ProcessDir(DirPtr,DirName+'\'+DirPtr^.FileName)ã {recursively process subdirectories}ã elseã WriteLn(DirName+'\'+DirPtr^.FileName);ã DirPtr := DirEntryPtr(D^.DirEntries.Next(DirPtr));ã end;ã end;ããããbeginãOrig := CurDir;ãWriteLn('Palcic''s File Finder v1.0');ããif ParamCount = 0 then { Syntax is incorrect }ã beginã WriteLn;ã WriteLn('Syntax: PFF filespec');ã WriteLn;ã WriteLn('Directory names can not be passed.');ã WriteLn;ã WriteLn('Example: PFF *.ZIP');ã WriteLn;ã Halt;ã end;ããChDir('C:\');ãNew(DP,Clear);ããWriteLn;ãWrite('Scanning for ',ParamStr(1),'...');ãDP^.FindDirectories(ParamStr(1),Archive);ãWriteLn;ãWriteLn;ããProcessDir(DP,'C:');ããWriteLn;ãWriteLn('Back to original directory ',Orig);ãChDir(Orig);ããSt.Init('PFF.DAT',SCreate);ãDP^.Store(St);ãSt.Done;ããDispose(DP,Done);ããend.ã 28 02-15-9408:41ALL SWAG SUPPORT TEAM DOS Search Engine IMPORT 40 ¦¶ k UNIT Engine;ãã{$V-}ãã(**************************************************************************)ã(* SEARCH ENGINE *)ã(* Input Parameters: *)ã(* Mask : The file specification to search for *)ã(* May contain wildcards *)ã(* Attr : File attribute to search for *)ã(* Proc : Procedure to process each found file *)ã(* *)ã(* Output Parameters: *)ã(* ErrorCode : Contains the final error code. *)ã(**************************************************************************)ãã(************************)ã(**) INTERFACE (**)ã(************************)ããUSES DOS;ããTYPEã ProcType = PROCEDURE (VAR S : SearchRec; P : PathStr);ã FullNameStr = STRING[12];ãã PROCEDURE SearchEngine(Mask : PathStr; Attr : Byte; Proc : ProcType; VAR ErrorCode : Byte);ãã FUNCTION GoodDirectory(S : SearchRec) : Boolean;ã PROCEDURE ShrinkPath(VAR path : PathStr);ã PROCEDURE ErrorMessage(ErrCode : Byte);ã PROCEDURE SearchEngineAll(path : PathStr; Mask : FullNameStr; Attr : Byte; Proc : ProcType; VAR ErrorCode : Byte);ãã (************************)ã (**) IMPLEMENTATION (**)ã (************************)ããVARã EngineMask : FullNameStr;ã EngineAttr : Byte;ã EngineProc : ProcType;ã EngineCode : Byte;ãã PROCEDURE SearchEngine(Mask : PathStr; Attr : Byte; Proc : ProcType; VAR ErrorCode : Byte);ãã VARã S : SearchRec;ã P : PathStr;ã Ext : ExtStr;ãã BEGINã FSplit(Mask, P, Mask, Ext);ã Mask := Mask + Ext;ã FindFirst(P + Mask, Attr, S);ã IF DosError <> 0 THENã BEGINã ErrorCode := DosError;ã Exit;ã END;ãã WHILE DosError = 0 DOã BEGINã Proc(S, P);ã FindNext(S);ã END;ã IF DosError = 18 THEN ErrorCode := 0ã ELSE ErrorCode := DosError;ãEND;ããFUNCTION GoodDirectory(S : SearchRec) : Boolean;ãBEGINã GoodDirectory := (S.name <> '.') AND (S.name <> '..') AND (S.Attr AND Directory = Directory);ãEND;ããPROCEDURE ShrinkPath(VAR path : PathStr);ãVAR P : Byte;ã Dummy : NameStr;ãBEGINã FSplit(path, path, Dummy, Dummy);ã Dec(path[0]);ãEND;ãã{$F+} PROCEDURE SearchOneDir(VAR S : SearchRec; P : PathStr); {$F-}ã {Recursive procedure to search one directory}ãBEGINã IF GoodDirectory(S) THENã BEGINã P := P + S.name;ã SearchEngine(P + '\' + EngineMask, EngineAttr, EngineProc, EngineCode);ã SearchEngine(P + '\*.*',Directory OR Archive, SearchOneDir, EngineCode);ã END;ãEND;ããPROCEDURE SearchEngineAll(path : PathStr; Mask : FullNameStr; Attr : Byte; Proc : ProcType; VAR ErrorCode : Byte);ããBEGINã (* Set up Unit global variables for use in recursive directory search procedure *)ã EngineMask := Mask;ã EngineProc := Proc;ã EngineAttr := Attr;ã SearchEngine(path + Mask, Attr, Proc, ErrorCode);ã SearchEngine(path + '*.*', Directory OR Attr, SearchOneDir, ErrorCode);ã ErrorCode := EngineCode;ãEND;ããPROCEDURE ErrorMessage(ErrCode : Byte);ãBEGINã CASE ErrCode OFã 0 : ; {OK -- no error}ã 2 : WriteLn('File not found');ã 3 : WriteLn('Path not found');ã 5 : WriteLn('Access denied');ã 6 : WriteLn('Invalid handle');ã 8 : WriteLn('Not enough memory');ã 10 : WriteLn('Invalid environment');ã 11 : WriteLn('Invalid format');ã 18 : ; {OK -- merely no more files}ã ELSE WriteLN('ERROR #', ErrCode);ã END;ãEND;ãããEND.ããã{ =============================== DEMO ==============================}ãã{$R-,S+,I+,D+,F-,V-,B-,N-,L+ }ã{$M 2048,0,0 }ãPROGRAM DirSum;ã (*******************************************************)ã (* Uses SearchEngine to write the names of all files *)ã (* in the current directory and display the total disk *)ã (* space that they occupy. *)ã (*******************************************************)ãUSES DOS,ENGINE;ããVARã Template : PathStr;ã ErrorCode : Byte;ã Total : LongInt;ãã{$F+} PROCEDURE WriteIt(VAR S : SearchRec; P : PathStr); {$F-}ãBEGIN WriteLn(S.name); Total := Total + S.Size END;ããBEGINã Total := 0;ã GetDir(0, Template);ã IF Length(Template) = 3 THEN Dec(Template[0]);ã {^Avoid ending up with "C:\\*.*"!}ã Template := Template + '\*.*';ã SearchEngine(Template, AnyFile, WriteIt, ErrorCode);ã IF ErrorCode <> 0 THEN ErrorMessage(ErrorCode) ELSEã WriteLn('Total size of displayed files: ', Total : 8);ãEND.ã 29 02-22-9411:40ALL SWAG SUPPORT TEAM Directory Select FunctionIMPORT 116 ¦¶ Program DIRSEL;ãUsesã Crt,Dos; { ** needed for DIRSELECT functions ** }ãã{ ** The following Type & Var declarations are for the main program only ** }ã{ ** However, the string length of the returned parameter from DIRSELECT ** }ã{ ** must be a least 12 characters. ** }ããTypeã strtype = String[12];ãVarã spec,fname : strtype;ãã{ ************************************************************************** }ã{ ** List of Procedures/Functions needed for DIRSELECT ** }ã{ ** Procedure CURSOR - turns cursor on or off ** }ã{ ** Procedure FRAME - draws single or double frame ** }ã{ ** Function ISCOLOR - returns the current video mode ** }ã{ ** Procedure SAVESCR - saves current video screen ** }ã{ ** Procedure RESTORESCR - restores old video screen ** }ã{ ** Procedure SCRGET - get character/attribute ** }ã{ ** Procedure SCRPUT - put character/attribute ** }ã{ ** Procedure FNAMEPOS - finds proper screen position ** }ã{ ** Procedure HILITE - highlights proper name ** }ã{ ** Function DIRSELECT - directory selector ** }ã{ ************************************************************************** }ããProcedure CURSOR( attrib : Boolean );ãVarã regs : Registers;ãBeginã If NOT attrib Then { turn cursor off }ã Beginã regs.ah := 1;ã regs.cl := 7;ã regs.ch := 32;ã Intr($10,regs)ã Endã Else { turn cursor on }ã Beginã Intr($11,regs);ã regs.cx := $0607;ã If regs.al AND $10 <> 0 Then regs.cx := $0B0C;ã regs.ah := 1;ã Intr($10,regs)ã EndãEnd;ããProcedure FRAME(t,l,b,r,ftype : Integer);ãVarã i : Integer;ãBeginã GoToXY(l,t);ã If ftype = 2 Thenã Write(Chr(201))ã Elseã Write(Chr(218));ã GoToXY(r,t);ã If ftype = 2 Thenã Write(Chr(187))ã Elseã Write(Chr(191));ã GoToXY(l+1,t);ã For i := 1 To (r - (l + 1)) Doã If ftype = 2 Thenã Write(Chr(205))ã Elseã Write(Chr(196));ã GoToXY(l+1,b);ã For i := 1 To (r - (l + 1)) Doã If ftype = 2 Thenã Write(Chr(205))ã Elseã Write(Chr(196));ã GoToXY(l,b);ã If ftype = 2 Thenã Write(Chr(200))ã Elseã Write(Chr(192));ã GoToXY(r,b);ã If ftype = 2 Thenã Write(Chr(188))ã Elseã Write(Chr(217));ã For i := (t+1) To (b-1) Doã Beginã GoToXY(l,i);ã If ftype = 2 Thenã Write(Chr(186))ã Elseã Write(Chr(179))ã End;ã For i := (t+1) To (b-1) Doã Beginã GoToXY(r,i);ã If ftype = 2 Thenã Write(Chr(186))ã Elseã Write(Chr(179))ã EndãEnd;ããFunction ISCOLOR : Boolean; { returns FALSE for MONO or TRUE for COLOR }ãVarã regs : Registers;ã video_mode : Integer;ã equ_lo : Byte;ãBeginã Intr($11,regs);ã video_mode := regs.al and $30;ã video_mode := video_mode shr 4;ã Case video_mode ofã 1 : ISCOLOR := FALSE; { Monochrome }ã 2 : ISCOLOR := TRUE { Color }ã EndãEnd;ããProcedure SAVESCR( Var screen );ãVarã vidc : Byte Absolute $B800:0000;ã vidm : Byte Absolute $B000:0000;ãBeginã If NOT ISCOLOR Then { if MONO }ã Move(vidm,screen,4000)ã Else { else COLOR }ã Move(vidc,screen,4000)ãEnd;ããProcedure RESTORESCR( Var screen );ãVarã vidc : Byte Absolute $B800:0000;ã vidm : Byte Absolute $B000:0000;ãBeginã If NOT ISCOLOR Then { if MONO }ã Move(screen,vidm,4000)ã Else { else COLOR }ã Move(screen,vidc,4000)ãEnd;ããProcedure SCRGET( Var ch,attr : Byte );ãVarã regs : Registers;ãBeginã regs.bh := 0;ã regs.ah := 8;ã Intr($10,regs);ã ch := regs.al;ã attr := regs.ahãEnd;ããProcedure SCRPUT( ch,attr : Byte );ãVarã regs : Registers;ãBeginã regs.al := ch;ã regs.bl := attr;ã regs.ch := 0;ã regs.cl := 1;ã regs.bh := 0;ã regs.ah := 9;ã Intr($10,regs);ãEnd;ããProcedure FNAMEPOS(Var arypos,x,y : Integer);ã{ determine position on screen of filename }ãConstã FPOS1 = 2;ã FPOS2 = 15;ã FPOS3 = 28;ã FPOS4 = 41;ã FPOS5 = 54;ã FPOS6 = 67;ãBeginã Case arypos ofã 1: Begin x := FPOS1; y := 2 End;ã 2: Begin x := FPOS2; y := 2 End;ã 3: Begin x := FPOS3; y := 2 End;ã 4: Begin x := FPOS4; y := 2 End;ã 5: Begin x := FPOS5; y := 2 End;ã 6: Begin x := FPOS6; y := 2 End;ã 7: Begin x := FPOS1; y := 3 End;ã 8: Begin x := FPOS2; y := 3 End;ã 9: Begin x := FPOS3; y := 3 End;ã 10: Begin x := FPOS4; y := 3 End;ã 11: Begin x := FPOS5; y := 3 End;ã 12: Begin x := FPOS6; y := 3 End;ã 13: Begin x := FPOS1; y := 4 End;ã 14: Begin x := FPOS2; y := 4 End;ã 15: Begin x := FPOS3; y := 4 End;ã 16: Begin x := FPOS4; y := 4 End;ã 17: Begin x := FPOS5; y := 4 End;ã 18: Begin x := FPOS6; y := 4 End;ã 19: Begin x := FPOS1; y := 5 End;ã 20: Begin x := FPOS2; y := 5 End;ã 21: Begin x := FPOS3; y := 5 End;ã 22: Begin x := FPOS4; y := 5 End;ã 23: Begin x := FPOS5; y := 5 End;ã 24: Begin x := FPOS6; y := 5 End;ã 25: Begin x := FPOS1; y := 6 End;ã 26: Begin x := FPOS2; y := 6 End;ã 27: Begin x := FPOS3; y := 6 End;ã 28: Begin x := FPOS4; y := 6 End;ã 29: Begin x := FPOS5; y := 6 End;ã 30: Begin x := FPOS6; y := 6 End;ã 31: Begin x := FPOS1; y := 7 End;ã 32: Begin x := FPOS2; y := 7 End;ã 33: Begin x := FPOS3; y := 7 End;ã 34: Begin x := FPOS4; y := 7 End;ã 35: Begin x := FPOS5; y := 7 End;ã 36: Begin x := FPOS6; y := 7 End;ã 37: Begin x := FPOS1; y := 8 End;ã 38: Begin x := FPOS2; y := 8 End;ã 39: Begin x := FPOS3; y := 8 End;ã 40: Begin x := FPOS4; y := 8 End;ã 41: Begin x := FPOS5; y := 8 End;ã 42: Begin x := FPOS6; y := 8 End;ã 43: Begin x := FPOS1; y := 9 End;ã 44: Begin x := FPOS2; y := 9 End;ã 45: Begin x := FPOS3; y := 9 End;ã 46: Begin x := FPOS4; y := 9 End;ã 47: Begin x := FPOS5; y := 9 End;ã 48: Begin x := FPOS6; y := 9 End;ã 49: Begin x := FPOS1; y := 10 End;ã 50: Begin x := FPOS2; y := 10 End;ã 51: Begin x := FPOS3; y := 10 End;ã 52: Begin x := FPOS4; y := 10 End;ã 53: Begin x := FPOS5; y := 10 End;ã 54: Begin x := FPOS6; y := 10 End;ã 55: Begin x := FPOS1; y := 11 End;ã 56: Begin x := FPOS2; y := 11 End;ã 57: Begin x := FPOS3; y := 11 End;ã 58: Begin x := FPOS4; y := 11 End;ã 59: Begin x := FPOS5; y := 11 End;ã 60: Begin x := FPOS6; y := 11 End;ã 61: Begin x := FPOS1; y := 12 End;ã 62: Begin x := FPOS2; y := 12 End;ã 63: Begin x := FPOS3; y := 12 End;ã 64: Begin x := FPOS4; y := 12 End;ã 65: Begin x := FPOS5; y := 12 End;ã 66: Begin x := FPOS6; y := 12 End;ã 67: Begin x := FPOS1; y := 13 End;ã 68: Begin x := FPOS2; y := 13 End;ã 69: Begin x := FPOS3; y := 13 End;ã 70: Begin x := FPOS4; y := 13 End;ã 71: Begin x := FPOS5; y := 13 End;ã 72: Begin x := FPOS6; y := 13 End;ã 73: Begin x := FPOS1; y := 14 End;ã 74: Begin x := FPOS2; y := 14 End;ã 75: Begin x := FPOS3; y := 14 End;ã 76: Begin x := FPOS4; y := 14 End;ã 77: Begin x := FPOS5; y := 14 End;ã 78: Begin x := FPOS6; y := 14 End;ã 79: Begin x := FPOS1; y := 15 End;ã 80: Begin x := FPOS2; y := 15 End;ã 81: Begin x := FPOS3; y := 15 End;ã 82: Begin x := FPOS4; y := 15 End;ã 83: Begin x := FPOS5; y := 15 End;ã 84: Begin x := FPOS6; y := 15 End;ã 85: Begin x := FPOS1; y := 16 End;ã 86: Begin x := FPOS2; y := 16 End;ã 87: Begin x := FPOS3; y := 16 End;ã 88: Begin x := FPOS4; y := 16 End;ã 89: Begin x := FPOS5; y := 16 End;ã 90: Begin x := FPOS6; y := 16 End;ã 91: Begin x := FPOS1; y := 17 End;ã 92: Begin x := FPOS2; y := 17 End;ã 93: Begin x := FPOS3; y := 17 End;ã 94: Begin x := FPOS4; y := 17 End;ã 95: Begin x := FPOS5; y := 17 End;ã 96: Begin x := FPOS6; y := 17 End;ã 97: Begin x := FPOS1; y := 18 End;ã 98: Begin x := FPOS2; y := 18 End;ã 99: Begin x := FPOS3; y := 18 End;ã 100: Begin x := FPOS4; y := 18 End;ã 101: Begin x := FPOS5; y := 18 End;ã 102: Begin x := FPOS6; y := 18 End;ã 103: Begin x := FPOS1; y := 19 End;ã 104: Begin x := FPOS2; y := 19 End;ã 105: Begin x := FPOS3; y := 19 End;ã 106: Begin x := FPOS4; y := 19 End;ã 107: Begin x := FPOS5; y := 19 End;ã 108: Begin x := FPOS6; y := 19 End;ã 109: Begin x := FPOS1; y := 20 End;ã 110: Begin x := FPOS2; y := 20 End;ã 111: Begin x := FPOS3; y := 20 End;ã 112: Begin x := FPOS4; y := 20 End;ã 113: Begin x := FPOS5; y := 20 End;ã 114: Begin x := FPOS6; y := 20 End;ã 115: Begin x := FPOS1; y := 21 End;ã 116: Begin x := FPOS2; y := 21 End;ã 117: Begin x := FPOS3; y := 21 End;ã 118: Begin x := FPOS4; y := 21 End;ã 119: Begin x := FPOS5; y := 21 End;ã 120: Begin x := FPOS6; y := 21 Endã Elseã Beginã x := 0;ã y := 0;ã Endã EndãEnd;ããProcedure HILITE(old,new : Integer); { highlight a filename on the screen }ãVarã i,oldx,oldy,newx,newy : Integer;ã ccolor,locolor,hicolor,cchar : Byte;ãBeginã FNAMEPOS(old,oldx,oldy); { get position in the array of the filename }ã FNAMEPOS(new,newx,newy); { get position in the array of the filename }ã For i := 0 To 11 Doã Beginã If old < 121 Then { if valid position, reverse video, old selection }ã Beginã GoToXY((oldx + i),oldy);ã SCRGET(cchar,ccolor);ã locolor := ccolor AND $0F;ã locolor := locolor shl 4;ã hicolor := ccolor AND $F0;ã hicolor := hicolor shr 4;ã ccolor := locolor + hicolor;ã SCRPUT(cchar,ccolor)ã End;ã GoToXY((newx + i),newy); { reverse video, new selection }ã SCRGET(cchar,ccolor);ã locolor := ccolor AND $0F;ã locolor := locolor shl 4;ã hicolor := ccolor AND $F0;ã hicolor := hicolor shr 4;ã ccolor := locolor + hicolor;ã SCRPUT(cchar,ccolor)ã EndãEnd;ããFunction DIRSELECT(mask : strtype; attr : Integer) : strtype;ãConstã OFF = FALSE;ã ON = TRUE;ãVarã i,oldcurx,oldcury,ã newcurx,newcury,ã oldpos,newpos,ã scrrows,fncnt : Integer;ã ch : Char;ã dos_dir : Array[1..120] of String[12];ã fileinfo : SearchRec;ã screen : Array[1..4000] of Byte;ãBeginã fncnt := 0;ã FindFirst(mask,attr,fileinfo);ã If DosError <> 0 Then { if not found, return NULL }ã Beginã DIRSELECT := '';ã Exitã End;ã While (DosError = 0) AND (fncnt <> 120) Do { else, collect filenames }ã Beginã Inc(fncnt);ã dos_dir[fncnt] := fileinfo.Name;ã FindNext(fileinfo)ã End;ã oldcurx := WhereX; { store old CURSOR position }ã oldcury := WhereY;ã SAVESCR(screen);ã CURSOR(OFF);ã scrrows := (fncnt DIV 6) + 3;ã Window(1,1,80,scrrows + 1);ã ClrScr;ã GoToXY(1,1);ã i := 1;ã While (i <= fncnt) AND (i <= 120) Do { display all filenames }ã Beginã FNAMEPOS(i,newcurx,newcury);ã GoToXY(newcurx,newcury);ã Write(dos_dir[i]);ã Inc(i)ã End;ã FRAME(1,1,scrrows,80,1); { draw the frame }ã HILITE(255,1); { highlight the first filename }ã oldpos := 1;ã newpos := 1;ã While TRUE Do { get keypress and do appropriate action }ã Beginã ch := ReadKey;ã Case ch ofã #27: { Esc }ã Beginã Window(1,1,80,25);ã RESTORESCR(screen);ã GoToXY(oldcurx,oldcury);ã CURSOR(ON);ã DIRSELECT := '';ã Exit { return NULL }ã End;ã #71: { Home } { goto first filename }ã Beginã oldpos := newpos;ã newpos := 1;ã HILITE(oldpos,newpos)ã End;ã #79: { End } { goto last filename }ã Beginã oldpos := newpos;ã newpos := fncnt;ã HILITE(oldpos,newpos)ã End;ã #72: { Up } { move up one filename }ã Beginã i := newpos;ã i := i - 6;ã If i >= 1 Thenã Beginã oldpos := newpos;ã newpos := i;ã HILITE(oldpos,newpos)ã Endã End;ã #80: { Down } { move down one filename }ã Beginã i := newpos;ã i := i + 6;ã If i <= fncnt Thenã Beginã oldpos := newpos;ã newpos := i;ã HILITE(oldpos,newpos)ã Endã End;ã #75: { Left } { move left one filename }ã Beginã i := newpos;ã Dec(i);ã If i >= 1 Thenã Beginã oldpos := newpos;ã newpos := i;ã HILITE(oldpos,newpos)ã Endã End;ã #77: { Right } { move right one filename }ã Beginã i := newpos;ã Inc(i);ã If i <= fncnt Thenã Beginã oldpos := newpos;ã newpos := i;ã HILITE(oldpos,newpos)ã Endã End;ã #13: { CR }ã Beginã Window(1,1,80,25);ã RESTORESCR(screen);ã GoToXY(oldcurx,oldcury); { return old CURSOR position }ã CURSOR(ON);ã DIRSELECT := dos_dir[newpos];ã Exit { return with filename }ã Endã Endã EndãEnd;ãã{ ************************************************************************** }ã{ ** Main Program : NOTE that the following is a demo program only. ** }ã{ ** It is not needed to use the DIRSELECT function. ** }ã{ ************************************************************************** }ããBeginã While TRUE Doã Beginã Writeln;ã Write('Enter a filespec => ');ã Readln(spec);ã fname := DIRSELECT(spec,0);ã If Length(fname) = 0 Thenã Beginã Writeln('Filespec not found.');ã Haltã End;ã Writeln('The file you have chosen is ',fname,'.')ã EndãEnd.ãã{ ** EOF( DIRSEL.PAS ) ** }ã
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/