SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00037 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 & 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 <DirPath>, FindFiles will pass the path of all the Filesπ it finds that match <Mask> to the <FileDoer> Procedure. if <Recurse>π is True, all such Files in subdirectories beneath <DirPath> will beπ visited as well. if <Recurse> is False, the names of subdirectoriesπ in <DirPath> 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 Directory With FileSpec 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 Searching a Complete Drv 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 Delete Tree 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 TREVOR J. CARLSEN Disply DIR on screen 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('<DIR>')π 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 - <ESC> 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 Does DIR Exist ? 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 Another DIR Tree 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 { Special 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 Directory Viewer 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] := '<DIR>'π 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 Delete Directory 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 Make/Change DIR 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 FAST Make Directory 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 <panther!jaguar!hzarb@relay.iunet.it>ππ 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 }ππ{πts@uwasa.fi (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 jak@hdc.hha.dkπ 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 = '┌└┐┘──││';π 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('<dir>', 'Mm/dd/yy', 'Hh:mmt');π SetMask('*.*', AnyFile);π end;ππ {<AltP>: 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 do x:=x+' ';πend;πππvar x,b: set of char;πprocedure GetSet(s: string; EndSet: char; var k: byte);πvarπ c: char;π u: string;π i: byte;π A: Boolean;πbeginπ A := False;π if s[k]=',' then repeatπ inc(k)π until (k>=FileNameLen) or (s[k]=EndSet) or (s[k]<>',');π u := '';π if (k<FileNameLen) and (s[k]<>EndSet) 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 ª╢X■ π{ 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 ª╢ûY 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 ) ** }π 30 05-25-9408:09ALL LARRY HADLEY Directory Object SWAG9405 97 ª╢Ç {π Next in this continuing series of code: the actual directryπ object.π}ππUnit Dirs;π{π A directory management object from a concept originally by Allanπ Holub, as discussed in Byte Dec/93 (Vol 18, No 13, page 213)ππ Turbo Pascal code by Larry Hadley, tested using BP7.π}πINTERFACEππUses Sort, DOS;ππTYPEπ pSortSR = ^oSortSR;π oSortSR = OBJECT(oSortTree)π procedure DeleteNode(var Node); virtual;π end;ππ callbackproc = procedure(name :string; lev :integer);ππ prec = ^searchrec;ππ pentry = ^entry;π entry = recordπ fil :prec;π next, last :pentry;π end;ππ pdir = ^dir;π dir = recordπ flist :pentry;π count :word;π path :string[80];π end;ππ pDirectry = ^Directry;π Directry = OBJECTπ dirroot :pdir;ππ constructor Init(path, filespec :string; attribute :byte);π destructor Done;ππ procedure Load(path, filespec :string; attribute :byte);π procedure Sort;π procedure Print;π END;ππCONSTπ NotDir = ReadOnly+Hidden+SysFile+VolumeID+Archive;π dosattr : array[0..8] of char = '.rhsvdaxx';ππprocedure TraverseTree(root :string; pcallproc :pointer; do_depth :boolean);ππIMPLEMENTATIONππvarπ treeroot :pSortSR; { sorting tree object }ππprocedure disposelist(ls :pentry);πvarπ lso :pentry;πbeginπ while ls<>NIL doπ beginπ dispose(ls^.fil);π lso := ls;π ls := ls^.next;π dispose(lso);π end;πend;ππ{ Define oSortSR.DeleteNode method so object knows how to dispose ofπ individual data pointers in the event that "Done" is called beforeπ tree is empty. }πprocedure oSortSR.DeleteNode(var Node);πvarπ pNode :pRec ABSOLUTE Node;πbeginπ dispose(pNode);πend;ππconstructor Directry.Init(path, filespec :string; attribute :byte);πvarπ pathspec :string;π node :pentry;π i :word;πBEGINπ FillChar(Self, SizeOf(Self), #0);π Load(path, filespec, attribute); { scan specified directory }π if dirroot^.count=0 then { if no files were found, abort }π beginπ if dirroot<>NIL thenπ beginπ disposelist(dirroot^.flist);π dispose(dirroot);π end;π FAIL;π end;π { the following code expands the pathspec to a full qualified path }π pathspec := dirroot^.path+'\';π node := dirroot^.flist;π while ((node^.fil^.name='.') or (node^.fil^.name='..')) andπ (node^.next<>NIL) doπ node := node^.next;π if node^.fil^.name='..' thenπ pathspec := pathspec+'.'π elseπ pathspec := pathspec+node^.fil^.name;π pathspec := FExpand(pathspec);π i := Length(pathspec);π repeatπ Dec(i);π until (i=0) or (pathspec[i]='\');π if i>0 thenπ beginπ Delete(pathspec, i, Length(pathspec));π dirroot^.path := pathspec;π end;πEND;ππdestructor Directry.Done;πbeginπ if dirroot<>NIL thenπ beginπ disposelist(dirroot^.flist);π dispose(dirroot);π end;πend;ππprocedure Directry.Load(path, filespec :string; attribute :byte);π{ scan a specified directory with a specified wildcard and attributeπ byte }πvarπ count : word;π pstr : pathstr;π dstr : dirstr;π srec : SearchRec;π dirx : pdir;π firstfl, thisfl, lastfl : pentry;πbeginπ count := 0;π New(firstfl);π with firstfl^ doπ beginπ next := NIL; last := NIL; New(fil);π end;π thisfl := firstfl; lastfl := firstfl;π dstr := path;π if path = '' then dstr := '.';π if dstr[Length(dstr)]<>'\' then dstr := dstr+'\';π if filespec = '' then filespec := '*.*';π pstr := dstr+filespec;ππ FindFirst(pstr, attribute, srec);π while DosError=0 do { while new files are found... }π beginπ if srec.attr = (srec.attr and attribute) thenπ { make sure the attribute byte matches our required atttribute mask }π beginπ if count>0 thenπ { if this is NOT first file found, link in new node }π beginπ New(thisfl);π lastfl^.next := thisfl;π thisfl^.last := lastfl;π thisfl^.next := NIL;π New(thisfl^.fil);π lastfl := thisfl;π end;π thisfl^.fil^ := srec;π Inc(count);π end;π FindNext(srec);π end;π { construct root node }π New(dirx);π with dirx^ doπ flist := firstfl;π dirx^.path := path; { path specifier for directory list }π dirx^.count := count; { number of files in the list }ππ if dirroot=NIL thenπ dirroot := dirxπ elseπ beginπ disposelist(dirroot^.flist);π dispose(dirroot);π dirroot := dirx;π end;πend;ππ{ The following function is the far-local function needed for theπ SORT method (which uses the sort unit posted earlier)π Note that this is hard-coded to sort by filename, then extension.π I plan to rewrite this later to allow user-selectable sortπ parameters and ordering. }πfunction Comp(d1, d2 :pointer):integer; far;π varπ data1 :pRec ABSOLUTE d1;π data2 :pRec ABSOLUTE d2;π name1, name2, ext1, ext2 :string;π beginπ { This assures that the '.' and '..' dirs will always be the firstπ listed. }π if (data1^.name='.') or (data1^.name='..') thenπ beginπ Comp := -1;π EXIT;π end;π if (data2^.name='.') or (data2^.name='..') thenπ beginπ Comp := 1;π EXIT;π end;π with data1^ doπ beginπ name1 := Copy(name, 1, Pos('.', name)-1);π ext1 := Copy(name, Pos('.', name)+1, 3);π end;π with data2^ doπ beginπ name2 := Copy(name, 1, Pos('.', name)-1);π ext2 := Copy(name, Pos('.', name)+1, 3);π end;π if name1=name2 thenπ { If filename portion is equal, use extension to resolve tie }π beginπ if ext1=ext2 thenπ { There should be NO equal filenames, but handle anyways forπ completeness... }π Comp := 0π elseπ if ext1>ext2 thenπ Comp := 1π elseπ Comp := -1;π endπ elseπ if name1>name2 thenπ Comp := 1π elseπ Comp := -1;π end;ππ{ Sort method uses the sort unit to sort the collected directoryπ entries. }πprocedure Directry.Sort;πvarπ s1, s2 :string;π p1 :pentry;ππ { This local procedure keeps code more readable }π procedure UpdatePtr(var prev :pentry; NewEntry :pointer);π beginπ if NewEntry<>NIL then { check to see if tree is empty }π beginπ New(prev^.next);π prev^.next^.fil := NewEntry;π prev^.next^.last := prev;π prev := prev^.next;π prev^.next := NIL;π endπ elseπ prev := prev^.next;π { tree is empty, flag "done" with NIL pointer }π end;ππbeginπ p1 := dirroot^.flist;π New(treeroot, Init(Comp));π{ Create a sort tree, point to our COMP function }π while p1<>NIL doπ{ Go through our linked list and insert the items into the sortingπ tree, dispose of original nodes as we go. }π beginπ if p1^.last<>NIL thenπ dispose(p1^.last);π treeroot^.InsertNode(p1^.fil);π if p1^.next=NIL thenπ beginπ dispose(p1);π p1 := NIL;π endπ elseπ p1 := p1^.next;π end;π{ Reconstruct directory list from sorted tree }π New(dirroot^.flist);π with dirroot^ doπ beginπ flist^.next := NIL;π flist^.last := NIL;π flist^.fil := treeroot^.ReadLeftNode;π end;π if dirroot^.flist^.fil<>NIL thenπ beginπ p1 := dirroot^.flist;π while p1<>NIL doπ UpdatePtr(p1, treeroot^.ReadLeftNode);π end;π{ We're done with sorting tree... }π dispose(treeroot, Done);πend;ππprocedure Directry.Print;π{ currently prints the entire list, may modify this later to allowπ selective printing }πvarπ s, s1 :string;π e :pentry;π dt :DateTime;π dbg :byte;ππ procedure DoDateEle(var sb :string; de :word);π beginπ Str(de, sb);π if Length(sb)=1 then { Add leading 0's}π sb := '0'+sb;π end;ππbeginπ if dirroot=NIL then EXIT; { make sure empty dirs aren't attempted }π e := dirroot^.flist;π while e<>NIL doπ beginπ s := '';π with e^.fil^ doπ beginπ dbg := 1;π repeatπ case dbg of { parse attribute bits }π 1: s := s+dosattr[(attr and $01)];π 2: s := s+dosattr[(attr and $02)];π 3: if (attr and $04) = $04 thenπ s := s+dosattr[3]π elseπ s := s+dosattr[0];π 4: if (attr and $08) = $08 thenπ s := s+dosattr[4]π elseπ s := s+dosattr[0];π 5: if (attr and $10) = $10 thenπ s := s+dosattr[5]π elseπ s := s+dosattr[0];π 6: if (attr and $20) = $20 thenπ s := s+dosattr[6]π elseπ s := s+dosattr[0];π elseπ s := s+dosattr[0];π end;π Inc(dbg);π until dbg>8;π s := s+' ';π { Kludge to make sure that extremely large files (>=100MB) don'tπ overflow size field... }π if size<100000000 thenπ Str(size:8, s1)π elseπ beginπ Str((size div 1000):7, s1); { decimal kilobytes }π s1 := s1+'k';π end;π s := s+s1+' ';π { Format date/time fields }π UnpackTime(Time, dt);π {month}π DoDateEle(s1, dt.month); s := s+s1+'/';π {day}π DoDateEle(s1, dt.day); s := s+s1+'/';π {year}π DoDateEle(s1, dt.year); s := s+s1+' ';π {hour}π DoDateEle(s1, dt.hour); s := s+s1+':';π {minutes}π DoDateEle(s1, dt.min); s := s+s1+':';π {seconds}π DoDateEle(s1, dt.sec); s := s+s1+' - ';π s := s+dirroot^.path+'\'+name;π end;π Writeln(s); s := '';π e := e^.next;π end;π Writeln; Writeln(' ', dirroot^.count, ' files found.'); Writeln;πend;ππ{ If TraverseTree is not given a callback procedure, this one isπ used. }πprocedure DefaultCallback(name :string; lev :integer); far;πvarπ s :string;πconstπ spaces = ' ';πbeginπ s := Copy(spaces, 1, lev*4); s := s+name;π Writeln(s);πend;ππ{ TraverseTree is untested as yet, rest of code (above) works fine.π Note that TraverseTree is NOT a member method of DIRECTRY. Readπ the BYTE Dec/93 article for a clarification of why it is goodπ that it not be a member.}πprocedure TraverseTree(root :string; pcallproc :pointer; do_depth :boolean);πvarπ level :integer;π fullpath :string;π rootdir :pdir;πconstπ callproc : callbackproc = DefaultCallBack;ππ { Actual recursive procedure to scan down directory structureπ using the DIRECTRY object. }π procedure Tree(newroot :string; callee :callbackproc; do_last :boolean);π varπ subdirs :pdirectry;π direntry :pentry;ππ Procedure DoDir;π beginπ New(subdirs, Init(newroot, '*.*', NotDir));π if subdirs<>NIL thenπ beginπ subdirs^.sort;π direntry := subdirs^.dirroot^.flist;π while direntry<>NIL doπ beginπ fullpath := newroot+'\'+direntry^.fil^.name;π callee(newroot, level);π direntry := direntry^.next;π end;π dispose(subdirs, done);π end;π end;ππ beginπ if not(do_last) thenπ DoDir;ππ New(subdirs, Init(newroot, '*.*', directory));ππ if subdirs<>NIL thenπ beginπ subdirs^.sort;π direntry := subdirs^.dirroot^.flist;π while direntry<>NIL doπ beginπ Inc(level);π fullpath := newroot+'\'+direntry^.fil^.name;π Tree(fullpath, callee, do_last);π dec(level);π direntry := direntry^.next;π end;π dispose(subdirs, done);π end;ππ if do_last thenπ DoDir;π end;ππbeginπ level := 0;ππ if pcallproc<>NIL thenπ callproc := callbackproc(pcallproc^);ππ root := fexpand(root);π if root[Length(root)]='\' thenπ Delete(root, Length(root), 1);ππ if not(do_depth) thenπ callproc(root, level);ππ Tree(root, callproc, do_depth);ππ if do_depth thenπ callproc(root, level);πend;ππEND.π 31 05-26-9406:20ALL TIMO SALMI Hiding a Directory IMPORT 8 ª╢─▒ {π> browsing. Q59 (How do you hide a directory?) leapt out at me as it'sπsomethingππQ53 actually.ππ> I have been trying to do for ages. However on closer examination theπ'solution'π> proved to be calling the SETFATTR function (either directly or through it'sπ> DOS interrupt.) This worried me- I am SURE I tried this, and withoutπsuccess.π> It worked fine for ordinary files, but NOT directories. In fact I have aππThat's very strange since I have no problems when I testπ}ππuses Dos;ππprocedure HIDE (dirname : string);πvar regs : registers;πbeginπ FillChar (regs, SizeOf(regs), 0);π dirname := dirname + #0;π regs.ah := $43;π regs.al := $01;π regs.ds := Seg(dirname[1]);π regs.dx := Ofs(dirname[1]);π regs.cx := 2; { set bit 1 on }π Intr ($21, regs);π if regs.Flags and FCarry <> 0 thenπ writeln ('Failed to hide');πend; (* hide *)ππbeginπ HIDE ('r:\tmpdir');πend.π 32 08-24-9413:19ALL STEVE ROGERS Recursing ALL Dirs SWAG9408 O)╠5 6 ª╢ π uses dos;π procedure ProcessAllFiles(dir : dirstr);π varπ d : searchrec;ππ beginπ while (dir[length(dir)] = '\') do dec(dir[0]);ππ { this gets the files }π findfirst(dir+'\*.*',anyfile+hidden+system+readonly,d);π while (doserror = 0) do beginπ process(d.name);π findnext(d);π end;ππ { this gets the subs, recursively }π findfirst(dir+'\*.*',directory,d);π while (doserror = 0) do beginπ if (d.attr and directory = directory) thenπ ProcessAllFiles(dir+'\'+d.name);π findnext(d);π end;ππ end;π 33 08-24-9413:31ALL DAVE JARVIS Recursive Directory SWAG9408 ¿=7⌐ 11 ª╢ {π On 05-25-94 ROBERT HARRISON wrote to ALL...ππ RH> I'm trying to obtain the source for searching for files in allπ RH> directories and drives. Anyone happened to have the informationπ RH> they would like to share with me? Thanks.ππ----------------- 8< ------------- }ππUSES DOS, Crt;ππPROCEDURE Search;πVARπ Err : INTEGER;π Attrib,π CurrDir : STRING;π DirInfo : SearchRec;ππBeginπ FindFirst( '*.*', AnyFile, DirInfo );ππ Err := 0;ππ WHILE Err = 0 DOπ Beginπ { If the directory wasn't . or .., then find all files in it ... }π IF ((DirInfo.Attr AND Directory) = Directory) ANDπ (Pos( '.', DirInfo.Name ) = 0) THENπ Beginπ {$I-}π ChDir( DirInfo.Name );π {$I+}ππ { Find all files in subdirectory that was found }π Search;π DirInfo.Attr := 0;π Endπ ELSEπ Beginπ GetDir( 0, CurrDir );π WriteLn( DirInfo.Name );π FindNext( DirInfo );ππ Err := DosError;π End;π End;ππ {$I-}π ChDir( '..' );π {$I+}ππ IF IOResult <> 0 THENπ { Do Nothing...probably root directory... };πEnd;ππVARπ CurDir : STRING;ππBeginπ ClrScr;π GetDir( 0, CurDir );π ChDir( 'C:\' );π Search;π ChDir( CurDir );πEnd.π 34 08-24-9413:40ALL PHIL OVERMAN GIF Directory SWAG9408 dïmJ 122 ª╢ Program GIFDIR(Input, Output);ππUses Dos, Crt;ππConstπ ProSoft = ' Gif DIRectory - Version 2.0 (C) ProSoft '+Chr(254)+' Phil R. Overman 02-02-92';π gifliteheader = chr($21)+chr($FF)+chr(11)+'GIFLITE';π giflitesearch = 100;π ScreenLines = 23;π Maxlinelength = 80;π test0 = false;π test1 = true;π(*π {$I-}π*)πTypeπ String12 = String[12];π LineType = Packed Array[1..Maxlinelength] of char;π LengthType = 0..Maxlinelength;π String2 = String[2];π String3 = String[3];π String8 = Packed Array[1..8] of char;π{ String12 = Packed Array[1..12] of char; }π String15 = String[15];ππVarπ dodate, dotime, domegs, doextension : boolean;π doversion, dopalette, doGCT : boolean;π dofiledot, doall, dogiflite : boolean;π CmtFound, Pause, ShowZips, isgif : Boolean;π CmtSize, FileCount, LinesWritten : Word;π attr, height, width, colors : Word;π fileattr : word;π TotalSize, position : Longint;π filesize, filedate : longint;π icount, jcount : integer;π count, clen : Byte;π megs : real;π DirInfo, gifdirinfo : Searchrec;π Path, Gifpath, filein : PathStr;π Dir : DirStr;π Name, infdatestring, gifname : NameStr;π Ext : ExtStr;π A, B, C, cc, ch, eoname : Char;π Abyte : Byte;π cs : String[1];π meg : String2;π gversion, gheader : String3;π filename : String[12];π infile, outfile : text;π giffile : file;π infdt, filedt : datetime;π giffilein : String15;π Drive : String2;π GCTF {1 Bit} : boolean;π ColorResolution {3 Bits} : byte;π SortFlag {1 Bit} : boolean;π SizeOfGCT {3 Bits} : byte;π giflite : boolean;π BackgroundColorIndex : Byte;π PixelAspectRatio : Byte;π SizeofPalette : Longint;π{ Cmt : CmtType; }π(***************************************************************)πProcedure BadParms;πbeginπ writeln(' Program syntax: GDIR [d:\Path][Filename[.GIF]] [/p/a/d/t/m/f/v/g/r/?|h]');π{ writeln; }π writeln(' Displays standard DOS DIR of GIF files, but with height, width, and colors');π{ writeln; }π writeln(' Output looks like this (with no parameters):');π{ writeln; }π writeln(' GIFNAME GIF 178152 5-11-91 640h 400w 256c');π writeln;π { writeln('Enter *.* to display all files (normal Dir).'); }π writeln(' Parameters:');π writeln(' /P Pauses the display, just as in the DOS Dir command.');π writeln(' /A Displays complete information, except time.');π writeln(' /D turns display of the file Date off.');π writeln(' /T turns display of the file Time on.');π writeln(' /M shows size in Megabytes instead of bytes.');π writeln(' /F displays GIFNAME.GIF instead of GIFNAME GIF');π writeln(' /E suppress display of the extension.');π writeln(' /G Check if file optimized by GIFLITE and display it if so.');π writeln(' /V displays the Version of the GIF file - GIF87a, GIF89a, etc.');π writeln(' /C displays "GCM" if the file has a Global Color Map');π writeln(' /R Resolution - displays the total number of colors in the pallette');π writeln(' /H or /? displays this Help screen.');π if Doserror > 0 then writeln;π If Doserror = 18 then Writeln(' File not found');π If Doserror = 3 then writeln(' Path not found');π if Doserror > 0 then writeln;π halt(98);πend;π(************************************************)πProcedure FlipB(Var f : boolean);πBeginπ If f then f := false else f := true;πEnd;π(************************************************)πProcedure ProcessParms(s : string);πvar sr : searchrec;πBeginπ If (pos('/',s) = 1) Thenπ Beginπ If (Copy(s,2,1) = 'P') or (Copy(s,2,1) = 'p') then Pause := true;π If (Copy(s,2,1) = 'D') or (Copy(s,2,1) = 'd') then Flipb(dodate);π If (Copy(s,2,1) = 'T') or (Copy(s,2,1) = 't') then Flipb(dotime);π If (Copy(s,2,1) = 'M') or (Copy(s,2,1) = 'm') then Flipb(domegs);π If (Copy(s,2,1) = 'F') or (Copy(s,2,1) = 'f') then Flipb(dofiledot);π If (Copy(s,2,1) = 'V') or (Copy(s,2,1) = 'v') then Flipb(doversion);π If (Copy(s,2,1) = 'R') or (Copy(s,2,1) = 'r') then Flipb(dopalette);π If (Copy(s,2,1) = 'G') or (Copy(s,2,1) = 'g') then Flipb(dogiflite);π If (Copy(s,2,1) = 'C') or (Copy(s,2,1) = 'c') then Flipb(doGCT);π If (Copy(s,2,1) = 'E') or (Copy(s,2,1) = 'e') then Flipb(doextension);π If (Copy(s,2,1) = 'A') or (Copy(s,2,1) = 'a') thenπ Beginπ Flipb(doall);π dodate := true; dotime := false; dofiledot := false;π domegs := false; doversion := true; dopalette := false;π doGCT := true; doextension := true; dogiflite := true;π End;π If (Copy(s,2,1) = 'H') or (Copy(s,2,1) = 'h') or (Copy(s,2,1) = '?') then Badparms;π Endπ Elseπ Beginπ Path := FExpand(s);π{ If Copy(Path,Length(Path),1) = '\' then Path := Path + '*.GIF'; }π{ If Pos('.',path) = 0 then path := path + '.GIF'; }π{ If Pos('*',Path) + Pos('?',path) + Pos('.GIF',path) = 0π thenπ beginπ FindFirst(Path,$10,sr);π If Doserror = 0 then Path := Path + '\*.gif';π end; }π End;πEnd;π(*******************)πFunction Exponential(A:integer; B:byte):longint;πVar yyy : longint;π(* Returns A to the Bth *)πBeginπ yyy := A;π For count := 2 to B Do yyy := yyy * A;π If b=0 then Exponential := 1 else Exponential := yyy;πEnd;π(**********************************)πFunction BV(A:byte; b:byte):byte; {BitValue}πvar aa : byte;π(* A is the byte value - b is the bit # for which the value is desired 1-8 *)πBeginπ aa := a;π While aa >= Exponential(2,b) do dec(aa,Exponential(2,b));π If aa < Exponential(2,b-1) then BV := 0 else BV := 1;πEnd;π(***********************)πProcedure ClearName;πBeginπ For count := 1 to 12 do DirInfo.name[count] := ' ';πEnd;π(**************************)πProcedure ClearABC;πBeginπ A := ' '; B := ' '; C := ' ';πEnd;π(*******************)π{πProcedure ClearCmt;πBeginπ CmtFound := False;π for count := 1 to MaxCmtSize do Cmt[count] := ' ';πEnd;π}π(*******************)πProcedure WriteName(n : String12);πVar p, q, qq, r : byte;πBeginπ p := 0; q := 0; r := 0;π If doextension then qq :=12 else qq := 8;π While r < length(n) DOπ Beginπ inc(p);π inc(r);π if (n[p] = '.') and not dofiledotπ thenπ Beginπ If p < 9 then write(' ':9-p);π inc(q, 9-p);π If doextension thenπ Beginπ write(' ');π inc(q);π End;π Endπ elseπ beginπ If (p<9) or doextension thenπ beginπ write(n[p]);π inc(q);π end;π end;π End;π If q < qq then write(' ':qq-q);πEnd;π(********************************)πProcedure WriteDate(i : longint);πVar d : datetime;πBeginπ Unpacktime(i,d);π If d.month > 9 then Write(d.month,'-') else Write('0',d.month,'-');π If d.day > 9 then Write(d.day) else Write('0',d.day);π Write('-',d.year mod 100);π Write(' ');πEnd;π(********************************)πProcedure WriteTime(i : longint);πVar d : datetime;πBeginπ Unpacktime(i,d);π Write(' ');π if d.hour = 0 then Write('12') else if d.hour mod 12 > 9 then Write(d.hour mod 12) else write(' ',d.hour mod 12);π if d.min = 0 then Write(':00') else if d.min > 9 then write(':',d.min) else Write(':0',d.min);π If d.hour > 11 then Write('p ') else Write('a ');πEnd;π(*****************************************************)πProcedure Writeline(s : Searchrec);πVar xx : byte; ss: string[1];πBeginπ Writename(s.name);π If domegs or doextension thenπ Beginπ xx := (s.size+5120) div 10240;π If xx < 10π thenπ beginπ Str(xx:1, ss);π meg := '0' + ssπ endπ elseπ Str(xx:2, meg)π End;π If domegs then Write(' .',meg,' ') else Write(s.size:10);π Write(' ');π If dodate then Writedate(s.time);π If dotime then WriteTime(s.time);π If isgif thenπ Beginπ Write(height:4,'h',width:4,'w',colors:4,'c ');π If dopalette then Write(sizeofpalette,'R ');π If doversion then Write (' ',gversion,' ');π If doGCT then begin if GCTF then Write(' GCM ') else write(' ') end;π If doGIFLITE then begin if GIFLITE then Write(' GL ') else write(' ng ') end;π End;π Writeln;πEnd;π(****************************************************)πProcedure ProcessGifFile;πVar result : word;πBEGINπ Assign(GifFile, Concat(Dir,DirInfo.name));π Reset(GifFile, 1);π isgif := false;π inc(filecount);π inc(totalsize,dirinfo.size);π ClearABC;π(* See if it's a GIF file. *)π Result := Pos('.',Dirinfo.name);π If (result > 0) andπ (Copy(DirInfo.name,result,Length(DirInfo.name)-result+1) = '.GIF')π then isgif := true;π{ Result := Filesize; }π If isgif { and (result>12) }π thenπ Beginπ blockread(GifFile, A, 1, result);π blockread(GifFile, B, 1, result);π blockread(GifFile, C, 1, result);π gheader := A + B + C;π End;π If gheader = 'GIF'π Thenπ Begin {GifFileFound!}π blockread(GifFile, A, 1, result);π blockread(GifFile, B, 1, result);π blockread(GifFile, C, 1, result);π gversion := A + B + C;π blockread(GifFile, height, 2, result);π blockread(GifFile, width, 2, result);π blockread(GifFile, Abyte, 1, result);π SizeOfGCT := BV(Abyte,1) + BV(Abyte,2)*2 + BV(Abyte,3)*4 +1;π colors := Exponential(2,SizeOfGCT);π If BV(Abyte,4) = 1 then SortFlag := true else SortFlag := false;π ColorResolution := BV(Abyte,5) + BV(Abyte,6)*2 + BV(Abyte,7)*4 +1;π SizeOfPalette := Exponential(2,ColorResolution);π SizeOfPalette := Exponential(SizeofPalette,3);π If BV(Abyte,8) = 1 then GCTF := true else GCTF := false;π Blockread(GifFile, BackgroundColorIndex, 1);π Blockread(GifFile, PixelAspectRatio, 1);π If dogifliteπ thenπ Beginπ giflite := false;π icount := 0;π count := 1;π jcount := giflitesearch;π If GCTF then inc(jcount,3*colors);π While (icount < jcount) and not giflite doπ Beginπ Blockread(Giffile, A, 1, result);π If A = Copy(gifliteheader, count, 1) thenπ Beginπ If count = length(gifliteheader)π thenπ giflite := trueπ elseπ inc(count)π End;π Inc(icount);π End;π End;π End;π Writeline(DirInfo);π Close(GifFile);π Inc(LinesWritten);πEND;π(**********************)πProcedure WriteVolLabel;πVar v : searchrec; c : byte;πBeginπ FindFirst(Copy(Path,1,3)+'*.*',VolumeID,v);π Write(' Volume in drive ',Copy(Path,1,1),' is ');π For c := 1 to length(v.name) do if v.name[c] <> '.' then write(v.name[c]);π Writeln;π Write(' Directory of ',Copy(Dir,1,Length(Dir)-1));π If Copy(Dir,2,1) = ':' then Write('\');π Writeln;π Writeln;πEnd;π(***************************************)πProcedure ParseParms(pps : string);πBegin { This only gets parms with a slash / in them. }πIf Pos('/',pps) <> 1 Then { This is the filename with a slash appended }π Beginπ{ ProcessParms(Copy(pps,1,Pos('/',pps)-1)); }π Path := Fexpand(Copy(pps,1,Pos('/',pps)-1));π pps := Copy(pps,Pos('/',pps),Length(pps)-Pos('/',pps)+1)π End;πWhile (Pos('/',pps) > 0) and (Length(pps) > 1) Doπ Beginπ ProcessParms(Copy(pps,1,2));π pps := Copy(pps,2,Length(pps)-1);π If Pos('/',pps) > 0 thenπ pps := Copy(pps,Pos('/',pps),Length(pps)-Pos('/',pps)+1);π End;πEnd;π(***************************************)πProcedure Initialize;πVar sr : searchrec;πBeginπ Assign(Input,''); Reset(Input);π Assign(Output,''); Rewrite(Output);π Writeln;π Writeln(ProSoft);π Writeln;π dodate := true; dotime := false; domegs := false; doextension := true;π dopalette := false; doGCT := false; doversion := false; pause := false;π dofiledot := false; dogiflite := true; doall := false;π gheader := ' '; gversion := ' ';π ClearABC; Clearname;π FileCount := 0; TotalSize := 0; LinesWritten := 0;π For count := 1 to Sizeof(path) do Path[count] := ' ';π For count := 1 to Sizeof(Dir) do Dir[count] := ' ';π For Count := 1 to Sizeof(Name) do Name[count] := ' ';π For count := 1 to Sizeof(Ext) do Ext[count] := ' ';π If paramcount = 0π thenπ Path := FExpand('*.GIF')π elseπ If Pos('/',paramstr(1)) = 1 then path := FExpand('*.GIF');π For Count := 1 to paramcount do If Pos('/',paramstr(count)) > 0π thenπ ParseParms(paramstr(count))π elseπ Path := Fexpand(paramstr(count));π{π FindFirst(Path,$10,sr);π If (Doserror = 0) and (sr.attr = $10) thenπ beginπ Path := Path + '\*.gif';π Path := FExpand(Path)π end;π}π Fsplit(Path,Dir,Name,Ext);π If (name = '') or (name = ' ') then name := '*';π If (Ext = '') or (Ext = ' ') then Ext := '.GIF';π Path := Dir + Name + Ext;πEnd;π(******************> Main <*********************)πBegin { Main }π Initialize;π FindFirst(Path,$21,DirInfo);π If Doserror = 0π thenπ Beginπ WriteVolLabel;π While DosError < 1 doπ Beginπ If (dirinfo.name = '.') or (dirinfo.name = '..')π thenπ For count := 1 to 12 do DirInfo.name[count] := ' 'π elseπ ProcessGifFile;π FindNext(DirInfo);π If pause and (LinesWritten = ScreenLines) and (DosError < 1)π thenπ Beginπ Writeln('Press any key to continue . . .');π AssignCrt(Input); Reset(Input);π AssignCrt(Output); Rewrite(Output);π ch := Readkey;π Assign(Input,''); Reset(Input);π Assign(Output,''); Rewrite(Output);π Writeln;π LinesWritten := 1;π End;π End;π Write(FileCount:9,' file');π If Filecount = 1 then Write(' ') else Write('s ');π cs := Copy(Path,1,1);π cc := cs[1];π count := ord(cc)-64;π Writeln(totalsize:12,' bytes');π Writeln(' ':16,diskfree(count):12,' bytes free ');π Writeln;π Endπ Elseπ Badparms;πEnd.π 35 08-25-9409:06ALL NEIL GORIN Create Directories SWAG9408 α<└ 23 ª╢ (*πRF> Has anyone written a function for creating a pathname ?πRF> I'm having a problem with putting together a function that youπRF> can pass a pathname to, such as: C:\WINDOWS\SYSTEM\STUFFπRF> and have it create the path if it's at all possible.ππTry the following, taken from a couple (one DOS, one Windows) ofπinstall programs I am working on. Lines beginning {} shouldπbe replaced with your preferred error reporting methods (theyπcurrently use my UNIXGUI package). This is not guaranteed toπtrap all possible errors.ππLEGALDIR will return true if the path is legal. You *must* specifyπthe drive in the path as in C:\WINDOWS\SYSTEM\STUFFπ*)πFunction LegalDir(path:string):boolean;π var flag:boolean;π beginπ path:=short(path);π flag:=true;π if path[1]<'A' then flag:=false;π if path[1]>'Z' then flag:=false;π if path[2]<>':' then flag:=false;π if path[3]<>'\' then flag:=false;π delete(path,1,3);π While path<>'' doπ beginπ if pos('\',path)>9 then flag:=false;π if ((length(path)>1) and (path[1]='\') and (path[2]='\'))π then flag:=false;π if path[1]=' ' then flag:=false;π if not (path[1] inπ ['A','B','C','D','E','F','G','H','I','J','K','L','M',π 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',π '1','2','3','4','5','6','7','8','9','0','_','^','$',π '~','!','#','%','&','-','{','}','(',')','\'])π then flag:=false;ππ delete(path,1,1);π end;π if not flag thenπ beginπ{} WinOkDialogue('Cannot Install',π 'Illegal Directory name!',π 'Please re-edit and',π 'try again.');π end;π LegalDir:=flag;π end;π{πMAKEDIRECTORY will make the directory structure you pass to it. Bestπto call LEGALDIR first, for obvious reasons.π}π Procedure MakeDirectory(st:string);π var ns:string;π ior:word;π beginπ Chdir(st);π if ioresult=0 then exit;π MKDIR(st);π ior:=ioresult;π if ior=3 thenπ beginπ ns:=st;π while ns[length(ns)]<>'\' do delete(ns,length(ns),1);π delete(ns,length(ns),1);π MakeDirectory(ns);π MakeDirectory(st);π end;π if ((ior<>0) and (ior<>3)) thenπ beginπ{} Popdialogue;π{} WinOkDialogue('Error',π 'Illegal Directory',π 'or drive error!',π 'Halting...');π{} closegui;π halt;π end;π end;π 36 08-25-9409:07ALL JOSE CAMPIONE ExistDir SWAG9408 '£åY 27 ª╢ (*ππ Here are three functions that I wrote to detect directories. The first π one uses findfirst, the second uses chdir and the third uses getfattr.π According to my benchmarkings the third one is the fastest (and the one π I preffer) . All of them need the DOS unit and will do the job as π requested, however, they are not exactly equivalent: The first functionπ will return false for d:= '<disk>:\', '\' or '..\'. They all return true π if the drive has been SUBSTituted.ππ Here are the results with some extreme strings (T = true, F = false)...ππ Function ---> 1 2 3 π -----------------------------------π d:= '' F F Fπ d:= '.' T T Tπ d:= '..' F T T (*)π d:= '.\' F F (@) Tπ d:= '..\' F T T (*)π d:= '\' F T Tπ d:= '/' F T (#) F π d:= 'c:\' F T Tπ d:= 'c:\.' F T Tππ (*) while logged in a non-root directory.π (@) chdir('.\') is not recognized as a valid change!π (#) chdir('/') switches to the root!ππ In all other situations the three functions return the same result.π π ---------------[cut]-----------------------------------------------π π function direxist1(d:pathstr): boolean;π varπ dirinfo: searchrec;π len : byte;π beginπ len:= length(d);π if (d[len] = '\') and {if d has a trailing slash and is... }π (len > 3) then {other than "<disk>:\", "..\"... }π dec(d[0]); {remove the trailing slash. }π findfirst(d,directory,dirinfo);{call findfirst. }π direxist1:= doserror = 0; {report boolean result }π end;ππ function direxist2(d:pathstr) : boolean;π varπ curdir: pathstr;π exist : boolean;π len : byte;π beginπ len:= length(d);π if (d[len] = '\') and {if d has a trailing slash and is... }π (len > 3) then {other than "<disk>:\" or "..\"... }π dec(d[0]); {remove the trailing slash. }π getdir(0,curdir); {get current dir }π {$I-} chdir(d); {$I+} {attempt changing directory }π exist := IOResult = 0; {test IOResult }π if exist then chdir(curdir); {if exist then go back to current dir }π direxist2:= (d <> '') and exist;π end;ππ function direxist3(d: pathstr): boolean;π varπ f : file;π attr: word;π len : byte;π beginπ len:= length(d);π if (d[len] = '\') then {if d has a trailing slash... }π dec(d[0]); {remove the trailing slash. }π d:= d + '\.'; {add '\.' to d }π assign(f,d); {assign d to f }π getfattr(f,attr); {get the attribute word }π direxist3 := ((attr and directory)=directory);π {return true if attr is directory }π end;ππ 37 08-25-9409:09ALL GREG VIGNEAULT Create Directories SWAG9408 °┼ 17 ª╢ {π>Has anyone written a function for creating a pathname ?π>I'm having a problem with putting together a function that youπ>can pass a pathname to, such as: C:\WINDOWS\SYSTEM\STUFFπ>and have it create the path if it's at all possible.π>the problem I'm having seems to stem from the fact that 'MKDIR()'π>can only handle making one directory which is under the current one.ππ This is because DOS' MkDir itself will fail if any element of aπ path is missing. You'll need to parse and build the path, goingπ directory by directory.ππ Here's some example code that you may use to create a MakePathπ function...π}ππPROGRAM MakePath; { Create a path. July 21,1994 Greg Vigneault }ππVAR Try, Slash : BYTE;π Error : WORD;π TmpDir, IncDir, NewDir, OurDir : STRING;πBEGINπ WriteLn;ππ NewDir := 'C:\000\111\222'; { an example path to create }ππ GetDir (0,OurDir); { because we'll use CHDIR to confirm directories }π WHILE NewDir[Length(NewDir)] = '\' DO DEC(NewDir[0]); { clip '\' }π IncDir := ''; { start with empty string }π REPEATπ Slash := Pos('\',NewDir); { check for slash }π IF (Slash <> 0) THEN BEGINπ IncDir := IncDir + Copy( NewDir, 1, Slash ); { get directory }π NewDir := Copy( NewDir, Slash+1, Length(NewDir)-Slash ); ENDπ ELSEπ IncDir := IncDir + NewDir;π TmpDir := IncDir;π IF (Length(TmpDir) > 3) THEN { clip any trailing '\' }π WHILE TmpDir[Length(TmpDir)] = '\' DO DEC(TmpDir[0]);π REPEATπ {$I-} ChDir(TmpDir); {$I+} { try to log into the directory... }π Error := IoResult;π IF (Error <> 0) THEN BEGIN { couldn't ChDir, so try MkDir... }π {$I-} MkDir(TmpDir); {$I+}π Error := IoResult;π END;π IF (Error <> 0) THEN INC(Try) ELSE Try := 0;π UNTIL (Error = 0) OR (Try > 3);π IF (Error = 0) THEN WriteLn('"',TmpDir,'" -- okay');π UNTIL (Slash = 0) OR (Error <> 0);ππ IF (Error <> 0) THEN WriteLn('MkDir ',TmpDir,' failed!',#7);ππ ChDir(OurDir); { log back into our starting directory }ππ WriteLn;πEND {MakePath}.π
