Ordner (incl. Dateien und Ordner) kopieren mit Progressbar

[Helmi]

Hallo,

ich würde gerne einen Ordner incl. aller Dateien und aller Unterordner kopieren.

Den Status des Kopierens würd ich gerne in einer Progressbar anzeigen.

Ich kenne die WinApi-Function "SHFileOperation". Kann diese aber in meinem Programm nicht verwenden (passt nicht ins Konzept).

Ich habe bereits schon eine Kopierfunction (dieser Schweizer-Code), aber eben nur für Dateien.

Weiss jemand wie ich es machen könnte?

[edit] Ach ja, die Progressbar sollte einmal komplett durchgelaufen sein, nachdem alle Dateien und Ordner kopiert wurden. [/edit]

[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.

:)

[Helmi]

Hallo,

Danke für deine Hilfe!

Darf ich deinen Code für meine Anforderungen verwenden und zerpflügen?

[Ferber]

Klar, sonst hätt ich ihn ja nicht hereingestellt. :-D

[Helmi]

Zitat:

Zitat von Ferber

Klar, sonst hätt ich ihn ja nicht hereingestellt. :-D

oki - Danke :-D

Na, bevor noch eine Rechnung reinschneit? *g* :spin2: :-D :???:

[Ferber]

Fehlt eigentlich das wesentliche - Die Kopierfunktion. Hier der Nachtrag.

Delphi-Quellcode:

unit MyUtils;

interface

uses SysUtils, ComCtrls, Dialogs;

// SourceFileName, TargetFileName - vollständige Dateinamen
// Zielpfad wird erzeugt falls nicht vorhanden

function CopyFileWithProgress(SourceFileName, TargetFileName:String; aPB:TProgressBar):Integer;

procedure CreatePath(Path:String);
function ChkPath(Path:String):String;

implementation

function CopyFileWithProgress(SourceFileName, TargetFileName:String; aPB:TProgressBar):Integer;
const
  BufSize:Integer=10240;
var
  Path:String;
  fi,fo:File;
  fSize,nRead,nWrite:Integer;
  Buf:Pointer;
begin
  Result:=0;
  Path:=ExtractFilePath(TargetFileName);
  try
    ChkPath(Path);
  except
    MessageDlg('Error creating Path: '+Path, mtError, [mbCancel], 0);
    exit;
  end;
  try AssignFile(fi, SourceFileName); Reset  (fi,1) except exit end;
  try AssignFile(fo, TargetFileName); Rewrite(fo,1) except CloseFile(fi); exit end;

  fSize:=FileSize(fi);

  if Assigned(aPB) then
    begin
      aPB.Position:=0;
      aPB.Max:=fSize;
    end;

  try
    GetMem(Buf ,BufSize)
  except
    CloseFile(fi);
    CloseFile(fo);
    exit
  end;

  try
    repeat
      BlockRead (fi,Buf^,BufSize, nRead);
      BlockWrite(fo,Buf^,nRead, nWrite);
      if Assigned(aPB) then aPB.Position:=FilePos(fi);
    until nWrite<BufSize;
    FileSetDate(TFileRec(fo).Handle, FileGetDate(TFileRec(fi).Handle));
  finally
    FreeMem(Buf);
    CloseFile(fi);
    CloseFile(fo);
    if Assigned(aPB) then aPB.Position:=0;
    Result:=fSize;
  end;
end;

procedure CreatePath;
var
  si:Integer;
begin
  if Path='' then exit;
  if Path[Length(Path)]<>'\'
     then Path:=Path+'\';
  for si:= 4 to Length(Path) do
      if Path[si]='\'
         then CreateDir(Copy(Path,1,si-1));
end;

function ChkPath(Path:String):String;
begin
  Result:=Path;
  CreatePath(Path);
end;

end.

Beispiel:

Delphi-Quellcode:

CopyFileWithProgress('D:\Subdir\Irgendeinfile.ext', 'C:\Subdir1\Subdir2\Test.txt', Progressbar1)

In eine Komponente gekapselt wirds noch komfortabler:

Delphi-Quellcode:

unit ProgressCopy;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, ComCtrls, ExtCtrls, Forms, Dialogs;

type
  TProgressCopy = class(TComponent)
  private
    FProgressbar:TProgressbar;
    FStatusPanel:TPanel;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    procedure Execute(SourceFileName, TargetFileName:String);
  published
    property Progressbar:TProgressbar read FProgressBar write FProgressbar;
    property StatusPanel:TPanel read FStatusPanel write FStatusPanel;
  end;

procedure Register;

implementation

uses MyUtils;

procedure Register;
begin
  RegisterComponents('MyCtrls', [TProgressCopy]);
end;

{ TProgressCopy }

procedure TProgressCopy.Execute(SourceFileName, TargetFileName: String);
begin
  if Assigned(FStatusPanel) then
    begin
      FStatusPanel.Caption:=TargetFileName;
      Application.ProcessMessages;
    end;
  CopyFileWithProgress(SourceFileName, TargetFileName, Progressbar);
  if Assigned(FStatusPanel) then FStatusPanel.Caption:=''
end;

procedure TProgressCopy.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) then
    begin
      if (AComponent = FProgressbar) then FProgressbar:=nil;
      if (AComponent = FStatusPanel) then FStatusPanel:=nil;
    end;
end;

end.

Beispiel:

Delphi-Quellcode:

ProgressCopy.Execute('D:\Subdir\Irgendeinfile.ext', 'C:\Subdir1\Subdir2\Test.txt')

Das Blockread und Blockwrite hat schon in TurboPascal gute Dienste geleistet ! :wink:

[Helmi]

Hallo,

Danke für einen Nachtrag! - Nur was muss ich jetzt wie benutzen um Ordner zu kopieren?
Ich blick da jetzt gerade nicht durch! - sorry!