Mappe struktur

Hej ZeroHero

Der findes ikke direkte en funktion til dette du skal skrive en algoritme der kan. vha. et findfirst..findnext..findclose loop ...

Et eksempel på en sådan skrevet i en tråd finder du på http://borrisholt.com under fileIO.

Jens B

Hov nu glemte jeg halvdelen af min kæphest : Fordelen ved en tråd implemen tering af denne algoritme er at den ikke belaster dit OS og den er meget hurtig (af samme grund).

Jens B

Du skal bruger FindFirst, FindNext til at løbe din disk igennem. For hver \"fil\" der finder skal du se om dette blot er en fil eller en folder (directory) hvis det er en folder så skal du ind og kigge på indholdet af denne hvorved det nemmest gøres ved at lave din routine rekursiv (det vil sige at den kalder sig selv).

Kig evt. i Delphi\'s hjælp for FindFirst/FindNext

Jeg kan anbefale det funktionsbibliotek som hedder JCL (Jedi Component Lib.) fra www.delphi-jedi.org hvorfra jeg har hugget følgende rutine som blot skal have en liste med ind:

function BuildFileList(const Path: string; const Attr: Integer; const List: TStrings): Boolean;
var
  SearchRec: TSearchRec;
  R: Integer;
begin
  Assert(List <> nil);
  R := FindFirst(Path, Attr, SearchRec);
  Result := Cardinal(R) <> INVALID_HANDLE_VALUE;
  if Result then
  begin
    while R = 0 do
    begin
      if (SearchRec.Name <> \'.\') and (SearchRec.Name <> \'..\') then
        List.Add(SearchRec.Name);
      R := FindNext(SearchRec);
    end;
    Result := R = ERROR_NO_MORE_FILES;
    SysUtils.FindClose(SearchRec);
  end;
end;

Kim Friis> Din (JCL\'s) løsning kigger ikke i evt. under foldere

Jammen lad os da bare oploade et komplet eksempel :

først vores algoritme :

unit Unit2;

interface

uses
  Classes, SysUtils;

type
  TFileFoundEvent = Procedure (FileName : TFileName; Attr: Integer) of object;

  TRecurseDirs = class(TThread)
  private
    VPath : String;
    VFileMask : TFileName;
    VDirMask : String;
    VAttr : Integer;
    VRecurse : Boolean;
    VWantAllDirs : Boolean;
    VOnFileFound :TFileFoundEvent;
    Function GatherFileName ( Path : String; FileName : TFileName) : String;
    Procedure Recurse (Path : String); overload;
    Procedure Recurse (Path : String; FilesInDir : Integer; Tmp : String; Attr : Integer ); overload;
  protected
    procedure Execute; override;
  public
    Constructor Create;
    Destructor Destroy; override;
    Procedure Start;
    Procedure Stop;
  published
    property Path        : String          read  VPath        write VPath;
    property FileMask    : TFileName      read  VFileMask    write VFileMask;
    property DirMask    : String          read  VDirMask    write VDirMask;
    property Attr        : Integer        read  VAttr        write VAttr;
    property RecurseDir  : Boolean        read  VRecurse    write VRecurse;
    property WantAllDirs : Boolean        read  VWantAllDirs write VWantAllDirs;
    property OnFileFound : TFileFoundEvent read  VOnFileFound write VOnFileFound;
  end;

implementation

{ TRecurseDirs }

constructor TRecurseDirs.Create;
begin
  FileMask        := \'*.*\';
  DirMask        := \'*.*\';
  Attr            := faAnyFile;
  RecurseDir      := true;
  FreeOnTerminate := true;
  WantAllDirs    := false;
  inherited Create(true);
end;

destructor TRecurseDirs.Destroy;
begin
inherited Destroy;
end;

procedure TRecurseDirs.Execute;
begin
  if not Assigned(VOnFileFound) then
    Exception.Create( Self.ClassName + \': No callback procedure defined !!!\');
if WantAllDirs then
  Recurse ( Path )
else
  Recurse ( Path, 0,Path,0);
end;

function TRecurseDirs.GatherFileName(Path: String;  FileName: TFileName): String;
begin
  while  Path[Length(Path)] = \'\\\' do
  Delete( Path, Length(Path), 1);

  result := Path + \'\\\' + FileName;
end;

procedure TRecurseDirs.Recurse(Path: String; FilesInDir: Integer; Tmp: String; Attr: Integer);
var
  VSearchRec : TSearchRec;
  res : integer;
begin
  res := FindFirst ( GatherFileName( Path,VFileMask), faAnyFile, VSearchRec);

  while (res = 0) and (not Terminated) do
  begin
    if (VSearchRec.Name[1] <> \'.\') and  ( VSearchRec.Attr and VAttr <> 0 ) then
    begin
      if VSearchRec.Attr and (faAnyFile-faDirectory) <> 0 then
      begin
        inc(FilesInDir);
        if (FilesInDir = 0) then
          VOnFileFound ( Tmp, Attr);
      end;
      VOnFileFound ( GatherFileName(Path,VSearchRec.Name), VSearchRec.Attr);
    end;
    res := FindNext (VSearchRec);
  end;//while

  FindClose (VSearchRec);

  if (VRecurse) and (not Terminated ) then
  begin
    res := FindFirst ( GatherFileName(Path,VDirMask), faAnyFile, VSearchRec);
    while ( res = 0)  and ( not Terminated ) do
    begin
      if (VSearchRec.Name[1] <> \'.\') and (VSearchRec.Attr and faDirectory <> 0) then
      begin
        FilesInDir := 0;
        if VSearchRec.Attr and VAttr  <> 0 then
        begin
          Tmp := GatherFileName(Path,VSearchRec.Name)+\'\\\';
          Attr := VSearchRec.Attr;
        end;
        Recurse ( GatherFileName(Path,VSearchRec.Name)+\'\\\', filesindir, Tmp, Attr);
      end;//if
      res := FindNext ( VSearchRec);
    end;//while
    FindClose ( VSearchRec);
  end;//if
end;

procedure TRecurseDirs.Recurse(Path: String);
var
  VSearchRec : TSearchRec;
  res : integer;
begin
  res := FindFirst ( GatherFileName( Path,VFileMask), faAnyFile, VSearchRec);

  while (res = 0) and (not Terminated) do
  begin
    if (VSearchRec.Name[1] <> \'.\') and  ( VSearchRec.Attr and VAttr <> 0 ) then
    begin
      if VSearchRec.Attr and (faAnyFile-faDirectory) <> 0 then
        VOnFileFound ( GatherFileName(Path,VSearchRec.Name), VSearchRec.Attr);
    end;
    res := FindNext (VSearchRec);
  end;//while

  FindClose (VSearchRec);

  if (VRecurse) and (not Terminated ) then
  begin
    res := FindFirst ( GatherFileName(Path,VDirMask), faAnyFile, VSearchRec);
    while ( res = 0)  and ( not Terminated ) do
    begin
      if (VSearchRec.Name[1] <> \'.\') and (VSearchRec.Attr and faDirectory <> 0) then
      begin
        if VSearchRec.Attr and VAttr  <> 0 then
          VOnFileFound ( GatherFileName(Path,VSearchRec.Name), VSearchRec.Attr);
        Recurse ( GatherFileName(Path,VSearchRec.Name)+\'\\\');
      end;//if
      res := FindNext ( VSearchRec);
    end;//while
    FindClose ( VSearchRec);
  end;//if
end;

procedure TRecurseDirs.Start;
begin
  Resume();
end;

procedure TRecurseDirs.Stop;
begin
  Terminate();
end;

end.


der efter tager du en form, med en listbox og en knap på:

til føj knappen et onclick event og listboxen et ondraw event (husk at sætte ListBox1\'s style til lbOwnerDrawFixed). Så skriv det følgende :

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Unit2;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
  private
    SearchThread: TRecurseDirs;
    SearchThread1: TRecurseDirs;
    Procedure FileFound(FileName : TFileName; Attr: Integer);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
    with TRecurseDirs.Create do
    begin
      Path := \'C:\\\';
      RecurseDir := true;
      OnFileFound := filefound;
      Start;
    end;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
    with Control as TListbox do
    begin
      Canvas.FillRect(Rect);
      if copy(TListBox(Control).Items[index],1,13) = \'Directory of \' then
        begin
          Canvas.Font.Color := clRed;
          Canvas.Font.Style:=Canvas.Font.Style+[fsBold];
        end;
      Canvas.TextOut(Rect.Left, Rect.Top, TListbox(Control).Items[Index]);
    end;
end;

procedure TForm1.FileFound(FileName: TFileName; Attr: Integer);
var
s : String;
begin
  if Attr = faDirectory then
    s := \'Directory of \' + FileName
  else
    s := FileName;

  ListBox1.Items.Add(s);

end;

end.

Jens B

hov
    SearchThread: TRecurseDirs;
    SearchThread1: TRecurseDirs;
under private skal slettes.

jens B

Tak for alle de gode svar...

\"I er for seje\"... ZeroHero