{xlat to english: 16.Mar-1998
   USED FOR TUTORIAL PURPOSES ONLY!
   RECURSION, Directory search etc.
   NOT FOR REFERENCE, NO GUARANTEE, NOT VERY CLEVER.
   FOR BEGINNERS only.}

{now (1998) the program is still in use, with some minor enhancements for network
  search and search in all harddisk partitions}

back to tp.html (better use the Back-button on your browser}

Uses CRT, DOS ;

Type String12 = String[12] ;
     String80 = String[80] ; {could have been a PathStr (unit DOS) too}

Const Copirite : String80 ='SUCHE (c)1988 Ing.Franz Glaser MEG A-4191' ;
      MaxFiles=512 ;

Var S       : String ;
    S2      : String80 ;
    OutFile : Text ;
    DirCount: Integer ;
    DirNum  : Integer ;
    IS      : Integer ;
    DosVer  : Word ;
    GSize   : Longint ;
    LogDir  : String80 ;
    SrchFile: String80 ;
    SrchPath: String80 ; {79 is max in plain MSDOS}
    Ch      : Char ;
    Sorting : Boolean ;
    OldX    : Byte;
    Redir   : Boolean;
    DirName : Array[1..MaxFiles] of String80 ;
    DirTime : Array[1..MaxFiles] of Longint ;

Procedure WriteDir(Num : Integer) ;
Var S,S1 : String ;
    PosSpace : Integer ;
Begin
  S := DirName[Num] ;
  PosSpace := Pos('\ ',S) ;
  if PosSpace > 0 then
    Delete(S,PosSpace+1,1) ;
  Writeln(OutFile,S) ;
End ;

Procedure RecursionError ;
Begin
  WriteLn(^G) ;
(*WriteLn('Die Unterverzeichnisse scheinen in einer Schleife verkettet zu sein') ;
  WriteLn('Prüfen Sie die Disk, zB. mit CHKDSK!') ;*)
  Writeln('The subdirectories seem to be chained in a loop');
  Writeln('Check the disk, eg. with CHKDSK');
  Halt(250) ;
End ;

Procedure AppendSlash (Var SS : String80) ;
Begin
  if SS[length(SS)] <> '\' then
    SS := SS+'\' ;
End ;

Procedure UpcStr (Var SS : String80) ;
Var I : Integer ;
Begin
  if length(SS) > 0 then
    for I := 1 to length(SS) do
      SS[I] := UpCase(SS[I]) ;
End ;

Procedure SearchFiles(PPath:String80) ;
Var SRCF : SearchRec ;
    S    : String12 ;
    SPF  : String80 ;
    ACount : Integer ;
Begin
  SPF := PPath ;
  AppendSlash(SPF) ;
  ACount := 0 ;
  if length(SPF) > 68 then
    Begin
      Sorting := false ;
    End ;
  With SRCF do
    Begin
      FindFirst(SPF+SrchFile,$23,SRCF) ;
      While (DosError=0) and (DirCount < MaxFiles) do
        Begin
          Inc(DirCount) ;
          if (Attr and 2)=2 then
            S := ' hidden'
          else
            S := '' ;
          DirName[DirCount] := SPF+' '+Name+S ;
          DirTime[DirCount] := Time ;
          GSize := GSize+((Size+1023)shr 10) ; {in kB}
          Inc(ACount) ;
          FindNext(SRCF) ;
        End ; {while}
    End ; {with srcf}
End ;

Procedure SearchDirs(PPath:String80;Recu:integer) ;
Var SRCD : SearchRec ;
    S    : String12 ;
    SPF  : String80 ;
Begin
  if Recu > 16 then RecursionError ;
  if length(PPath) > 75 then Halt(250) ; {emergency exit}
  SPF := PPath ;
  AppendSlash(SPF) ;
  Write(^M,SPF) ; ClrEol ;
  With SRCD do
    Begin
      FindFirst(SPF+'*.*',$10,SRCD) ; {dirs only}
      While (DosError=0) and (DirCount < MaxFiles) do
        Begin
          if ((Attr and $10)=$10) and (Name<>'.') and (Name<>'..') then
              {the check for Attr and $10 is necessary, because DOS does not
               guarantee to find subdirs only!}
            Begin
              SearchFiles(SPF+Name) ;
              SearchDirs(SPF+Name,Recu+1) ; {Recursion}
            End ;
          FindNext(SRCD) ;
        End ; {while}
    End ; {with srcd}
End ;

Procedure SortName ;
Var I : Integer ;
    TempNam : String80 ;
    ready : Boolean ;
Begin
  Write(^M' ... sorting') ; ClrEol ;
  ready := false ;
  While not ready do
    Begin
      ready := true ;
      For I := 1 to DirCount-1 do
        Begin
          if DirName[I] > DirName[Succ(I)] then
            Begin
              ready := false ;
              TempNam := DirName[I] ;
              DirName[I] := DirName[Succ(I)] ;
              DirName[Succ(I)] := TempNam ; {swap}
            End ;
        End ;
  End ; {while not ready, simple bubble sort}
  Write(^M) ; ClrEol ; {clr "sorting"}
End ;

Procedure SortTime ;
Var I : Integer ;
    Loops   : Integer;
    TempNam : String80 ;
    TempTim : Longint ;
    ready  : Boolean ;
Begin
  Write(^M' ... sorting by Date/Time ') ; ClrEol ;
  ready := false ;
  Loops := 0;
  While not ready do
    Begin
      ready := true ;
      if (Loops and $0F)=0 then Write('.');
      For I := 1 to DirCount-1 do
        Begin
          if DirTime[I] > DirTime[Succ(I)] then
            Begin
              ready := false ;
              TempNam := DirName[I] ;
              DirName[I] := DirName[Succ(I)] ;
              DirName[Succ(I)] := TempNam ;
              TempTim := DirTime[I] ;
              DirTime[I] := DirTime[Succ(I)] ;
              DirTime[Succ(I)] := TempTim ;
            End ;
        End ;
    Inc(Loops);
  End ; {while not ready, primitive bubble sort}
  Write(^M) ; ClrEol ;
End ;

Procedure HelpProc ;
Begin
{SINCE THE PROGRAM IS NOT INTENDED THAT YOU CREATE YOUR OWN SUCHE:.EXE FILE,
 THE HELP TEXT IS NOT TRANSLATED}
  ClrScr ;
  TextAttr := $0E;
  Write('>>>-- SUCHE -->') ;  {in German suche! = search!}
  WriteLn('(c)1988 by Ing.Franz Glaser  M E G  A-4191':64) ;
  TextAttr := $07;
  WriteLn('Ver.3.5 13.Apr-91':79) ;
  WriteLn ;
  WriteLn(' für MSDOS formattierte Disks. Sucht Dateien auf der ganzen Disk.') ;
  WriteLn(' Aufruf: C>Suche C:*.TXT {/S}   ?berall auf C:.') ;
  WriteLn('   oder: C>Suche A:\TEXT\ER???.TXT {/S}  ab A:\TEXT\') ;
  WriteLn('   oder: C>Suche .\*.BAK /S  ab "hier".') ;
  WriteLn('   oder: C>Suche ..\MAT?.??? ab Mutter-Dir.') ;
  WriteLn('         C>Suche *.* ist nicht erlaubt!') ;
  WriteLn(' Ein/Ausgabeumleitung mit > ist möglich, /P erscheint nicht in der Datei.') ;
  WriteLn(' Suche schreibt nichts auf die Disk, außer mit >') ;
  WriteLn(' Die nnnn kB - Angabe ist einzeln auf volle 1024 Byte aufgerundet.') ;
  WriteLn(' SUCHE findet max. ',MaxFiles,' Dateien.');
  WriteLn(^M^J' Vorteile gegenüber MSDOS-SEARCH:') ;
  WriteLn('   1. Angabe von Root als Arbeitsverzeichnis entfällt.') ;
  WriteLn('   2. Sortiert Dateinamen mit /S oder') ;
  WriteLn('   3. Sortiert nach Datum mit /D. (ohne Anzeige des Datums)') ;
  WriteLn('   4. Automatische /P-Funktion.') ;
  WriteLn('   5. Anzeige Summe kB der Dateien.') ;
  Halt(255) ;
End ;

Begin
  if ParamCount < 1 then
    HelpProc ;
  DirectVideo := false ;
  Assign(OutFile,'') ;
  Rewrite(OutFile) ; {to enable > redirection}
  Sorting := true ;
  GetDir(0,LogDir) ;
  SrchPath := ParamStr(1) ;
  SrchFile := '' ;
  While KeyPressed do Ch := ReadKey ;
  GSize := 0 ;
  UpcStr(SrchPath) ;
  if Pos('/S',SrchPath) > 0 then HelpProc ;
  if SrchPath='?' then HelpProc ;
  if Pos('.\',SrchPath)=1 then
    Begin
      Delete(SrchPath,1,1) ;
      if LogDir[length(LogDir)]='\' then
        Delete(SrchPath,1,1) ;
      SrchPath := LogDir+SrchPath ;
    End
  else
    if Pos('..\',SrchPath)=1 then
      Begin
        Delete(SrchPath,1,3) ; { the dots }
        While  LogDir[length(LogDir)] <> '\' do
          Delete(LogDir,length(LogDir),1) ;
        SrchPath := LogDir+SrchPath ;
      End ;
  LogDir[0] := #2 ;
  if SrchPath[2]<>':' then
    SrchPath := LogDir+SrchPath ;
  if not (SrchPath[1] in ['A'..'Z']) then HelpProc ;
  IS := length(SrchPath) ;
  While (IS > 0) and not (SrchPath[IS] in ['\',':']) do
    Begin
      SrchFile := SrchPath[IS] + SrchFile ;
      Dec(IS) ;
      SrchPath[0] := Char(IS) ;
    End ;
  if (SrchFile='*.*') and (length(SrchPath)<3) then
    HelpProc ;  {allow *.* only in subdirs, not on whole disk}
  WriteLn ;
  DirCount:= 0 ;
  Fillchar(DirName[1][0],sizeof(DirName),#0) ;
  For IS := 1 to MaxFiles do
    DirName[IS] := 'empty' ; {not necessary except for sorting}
  Write(OutFile,'>>>-- SUCHE -->  ') ;
  WriteLn(OutFile,SrchPath,'  ',SrchFile) ;
  SearchFiles(SrchPath) ; {in root or workdir}
  SearchDirs(SrchPath,0) ;  {in tree}
  OldX := WhereX;
  Write(Outfile,' ');
  Redir := OldX = WhereX; {if redirected to a file, then the cursor on the CRT did not move}
  if Redir then Writeln('>>>-- SUCHE -->  ',SrchPath,'  ',SrchFile);
  Write(^M) ; ClrEol ;
  if DirCount > 0 then
    Begin
      if DirCount > 1 then
        Begin
          S2 := ParamStr(2) ;
          UpcStr(S2) ;
          if Sorting then
            Begin
              if S2='/S' then
                SortName ;
              if S2='/D' then
                SortTime ;
            End ;
        End ;
      For DirNum := 1 to DirCount do
        Begin
          WriteDir(DirNum) ;
          if ((DirNum mod 20) = 0) and (not Redir) then
            Begin
              Write('... bitte eine Taste') ; {press any key}
              Repeat until Keypressed ;
              While Keypressed do Ch := ReadKey ; {eatup typeahead buffer}
              Write(^M); ClrEol ;
              if Ch=^[ then Halt(3) ; {esc exit}
            End ;
        End ;
      if DirCount > 1 then S := 'en' else S := '  ' ; {file / files=Dateien}
      Writeln(OutFile,DirCount:4,' Datei',S,' gefunden.',GSize:9,' kB') ; {found}
      if DirCount >= MaxFiles then
        WriteLn(OutFile,'SUCHE zeigt maximal ',MaxFiles,' Dateien.') ;
      Close(OutFile) ;
    End
  else
    Begin
      Writeln('Keine Dateien gefunden') ; {no files found}
      Halt(1) ;
    End ;
End.

Roger Birus wrote:
>
> Kann mir jemand verraten wie man in TP ein Verzeichnis von CD
> einliesst und als TXTDatei abspeichern kann ?
Can anybody tell me how to read the directory of a CD and write
it as a textfile

{$S+,M 1024,0,64000}

Uses DOS;

Var Dir: String;

Procedure ScanDir; { Benötigt nur 6 byte Stack }  needs only 6 bytes of stack per path depth
Var SR: ^SearchRec;
Begin
  New(SR);
  FindFirst('*.*',AnyFile, SR^);
  While (DosError = 0) do
  With SR^ Do
  Begin
    If (Length(Name) >= 1) And (Name[1] <> '.')
       Then If ((Attr And Directory) <> 0)
               Then
                 Begin
                   ChDir(SR^.Name);
                   ScanDir;
                   ChDir('..');
                 End
               Else
                 Begin
                   GetDir(0,Dir);
                   { hier folgt die Ausgabe }  here is the output
                   Writeln(Dir,'\',SR^.Name);
                 End;
    FindNext(SR^);
  End;
  Dispose(SR);
End;

Begin
  ChDir('C:\');
  ScanDir;
End.

--
==== http://home.t-online.de/home/Antivivisektion/vivisek.htm ====
Up on a hill, as the day dissolves; With my pencil turning moments
into line; High above in the violet sky; A silent silver plane -
it draws a golden chain (Brian Eno: Spinning Away)