Ordner (incl. Dateien und Ordner) kopieren mit Progressbar

[Ferber]

Hi !
Hier zwei alte Kompos aus 1997 zu diesem Zweck. Eine kriecht durch die Verzeichnisse, die andere durch die Files.

Delphi-Quellcode:

unit MyParser;

interface

uses Windows, Classes, SysUtils, Masks, Forms;

type
  EFileFound = procedure (Search: TSearchRec; Name:String) of object;
  EPathEnter = procedure (Search: TSearchRec; Path:String; var DoThis:Boolean) of object;
  EPathExit  = procedure of object;

  TFileParser = class(TComponent)
  private
    Running     :Boolean;
    FFiles      :String;
    FFileFound  :EFileFound;
    procedure SetFiles(Value:String);
  protected
    procedure Parse(Path:String); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Execute(Path:String);
    procedure Terminate;
  published
    property Files      :String     read FFiles      write SetFiles;
    property OnFileFound:EFileFound read FFileFound  write FFileFound;
  end;

  TPathParser = class(TComponent)
  private
    Terminated  :Boolean;
    Running     :Boolean;
    FFileParser :TFileParser;
    FInitPath   :String;
    FPathEnter  :EPathEnter;
    FPathExit   :EPathExit;
    FStepDown   :EPathEnter;
  protected
    procedure Parse(Path:String); virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    procedure Execute;
    procedure Terminate;
  published
    property FileParser  :TFileParser read FFileParser write FFileParser;
    property InitialPath :String      read FInitPath   write FInitPath;
    property OnPathEnter :EPathEnter  read FPathEnter  write FPathEnter;
    property OnPathExit  :EPathExit   read FPathExit   write FPathExit;
    property OnStepDown  :EPathEnter  read FStepDown   write FStepDown;
  end;

Procedure Register;

implementation

Procedure Register;
begin
  RegisterComponents('MyCtrls', [TFileParser, TPathParser]);
end;

{ utils }

function AddPath(s1,s2:String):String;
begin
  if s1='' then Result:=s2 else
  if s2='' then Result:=s1 else
     begin
       if s1[Length(s1)]='\' then s1:=copy(s1,1,Length(s1)-1);
       if s2[1]        <>'\' then s2:='\'+s2;
       Result:=s1+s2
     end;
end;

{ TFileParser -----------------------------------------------------------------}

constructor TFileParser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFiles:='*.*';
end;

procedure TFileParser.SetFiles(Value:String);
var
  si:Integer;
begin
  if FFiles=Value then exit;
  si:=Pos('\',Value);
  if Value= '' then Value:='*.*' else
  if Value='.' then Value:='*.*' else
  if    si>0   then Value:=Copy(Value, si+1, 255);
  FFiles:=Value;
end;

procedure TFileParser.Parse(Path:String);
var
  Search:TSearchRec;
  Status:Integer;
begin
  if Path   ='' then GetDir(0,Path);
  if FFiles ='' then FFiles:='*.*';
  Status   := FindFirst(AddPath(Path, FFiles), faAnyFile, Search);
  try
    while (Status = 0) and Running do
    begin
      if (Search.Attr and faDirectory) = 0 then
        if (Search.Name<>'.') and (Search.Name<>'..') then
          if Assigned(FFileFound) then
                      FFileFound(Search, AddPath(Path, Search.Name));
      Status := FindNext(Search);
    end;
  finally
    FindClose(Search);
  end;
end;

procedure TFileParser.Execute(Path:String);
begin
  Running:=True;
  Parse(Path);
end;

procedure TFileParser.Terminate;
begin
  Running:=False;
end;

{ TPathParser ----------------------------------------------------------------}

procedure TPathParser.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FFileParser) then
    FFileParser := nil;
end;

procedure TPathParser.Parse(Path:String);
var
  Search: TSearchRec;
  Status: Integer;
  DoThis: Boolean;
begin
  if Terminated then exit;
  if Path='' then GetDir(0,Path);
  DoThis:= True;
  if Assigned(FPathEnter) then FPathEnter(Search, Path, DoThis);
  if Terminated then exit;
  if Assigned(FileParser) then
     if DoThis then
        if Running then
           FileParser.Execute(Path);
  if Terminated then exit;
  //
  Status := FindFirst(AddPath(Path, '*.*'), faDirectory, Search);
  try
    while (Status = 0) and Running do
    begin
      if (Search.Name <> '.') and (Search.Name <> '..') then
        if (Search.Attr and faDirectory = faDirectory)
          then
            begin
              DoThis:=True;
              if Assigned(FStepDown) then
                          FStepDown(Search, AddPath(Path, Search.Name), DoThis);
              if DoThis then
                 if running then
                    Parse(AddPath(Path, Search.Name));
            end;
      Status := FindNext(Search);
    end;
  finally
    FindClose(Search);
  end;
  if Assigned(FPathExit)  then FPathExit;
  if Terminated then exit;
end;

procedure TPathParser.Execute;
begin
  Terminated:=False;
  Running   :=True;
  Parse(InitialPath);
end;

procedure TPathParser.Terminate;
begin
  Terminated:=True;
  Running   :=False;
  if Assigned(FileParser) then
     FileParser.Terminate;
end;

end.