copyfile.pas

本系统在一些大中型企业(跨多达24个区域)一直都在很好的服务过

              toCopy := Source.Size-Source.Position
            else
              toCopy := ChunkSize;
            Dest.CopyFrom( source, toCopy );
              Inc( FBytesCopied, toCopy );
            if Size > 0 then
              FProcessed := Round(FBytesCopied*100/Size)
            else
              FProcessed := 0;
            SetProgress( Round(FProcessed) );
          until Dest.Size = Source.Size;
          If FTransferTimeDate=True then FileSetDate(Dest.Handle,FileGetDate(Source.Handle));
             { Above line was suggested by Russel Havens, USA.}
          CanDelete := True;
        finally
          Dest.Free;
          if FCancelOperation then
            DeleteFile( FCopyTo );
        end;
      finally
        Source.Free;
      end;
    finally
      if not FCancelOperation then
        begin
          if TransferFileAttributes then
            FileSetAttr( FCopyTo, FileGetAttr( FCopyFrom ) );
          If FMoveFile and CanDelete Then
             DeleteFile(FCopyFrom);
        end;
      Finish;
    end;
  end
  else
    If FOnNotExists <> '' then Showmessage(FOnNotExists);
end;

procedure TCustomCopyFile.Start;
begin
  Inc(FStartCount);
  if FStartCount = 1 then
    begin
      FCopyMultipleFiles := True;
      FCancelOperation := False;
      if progress and not Assigned(FProgressForm) then
        begin
          FProgressForm := TProgForm.Create(Application);
          FProgressForm.Caption := FCaption;
          FProgressForm.Show;
        end;

      if SendEvents and Assigned(FOnStartOperation) then
        FOnStartOperation( Self );
    end
  else if Assigned(FProgressForm) then
    FProgressForm.Caption := FCaption;
end;

procedure TCustomCopyFile.Finish;
begin
  Dec(FStartCount);
  if FStartCount = 0 then
    begin
      FBytesToCopy := 0;
      FCopyMultipleFiles := False;
      if SendEvents and Assigned(FOnFinishOperation) then
        FOnFinishOperation( Self );
      if Assigned(FProgressForm) then
        begin
          FProgressForm.Free;
          FProgressForm := nil;
        end;
      BringToFront;
    end;
end;

function TCustomCopyFile.GetIsWorking : Boolean;
begin
  result := FStartCount > 0;
end;

procedure TCustomCopyFile.BringToFront;
begin
  if Assigned(Owner) and (Owner is TForm) then
    TForm(Owner).BringToFront;
end;

procedure TCustomCopyFile.WriteFileName( const filename : String );
begin
  if Assigned(FProgressForm) then
    begin
      if FShowFileNames then
        FProgressForm.Lfilename.Caption := filename
      else
        FProgressForm.Lfilename.Caption := '';
      FProgressForm.Lfilename.Update;
      Application.ProcessMessages;
    end;
  if SendEvents and Assigned( FOnEachFile ) then
    FOnEachFile( Self, filename );
end;

procedure TCustomCopyFile.SetProgress( progress : Integer );
begin
  if Assigned(FProgressForm) then
    begin
      FProgressForm.progressbar1.position:= progress;
      FProgressForm.progressbar1.Update;
      Application.ProcessMessages;
      FCancelOperation := FProgressForm.ModalResult = mrCancel;
    end;
  if SendEvents and Assigned(FOnOperationProgress) then
    FOnOperationProgress( Self, progress, FCancelOperation );
end;

procedure TCustomCopyFile.SetCaption( const str : String );
begin
  FCaption := str;
  if Assigned(FProgressForm) then
    begin
      FProgressForm.Caption := str;
      FProgressForm.Update;
    end;
end;

function TCustomCopyFile.AppendSlash(const sDir : String): String;
begin
  Result := sDir;
  if (Length(sDir)>0) and (sDir[Length(sDir)]<>'\') then
     Result := Result+'\';
end;

function TCustomCopyFile.RemoveSlash(const sDir : String): String;
begin
  Result := sDir;
  if (Length(sDir)>0) and (sDir[Length(sDir)]='\') then
     Delete( Result, length(sDir), 1 );
end;

procedure TCustomCopyFile.PrecalcDirSize( const dir : String );
var
  oldProgress, oldSendEvents : Boolean;
begin
  if FProgressKind = pkDirectory then
    begin
      FBytesCopied := 0;
      oldProgress := Progress;
      oldSendEvents := SendEvents;
      Progress := False;
      SendEvents := False;
      try
        FBytesToCopy := GetDirectorySize(dir);
      finally
        Progress := oldProgress;
        SendEvents := oldSendEvents;
      end;
    end;
end;

function TCustomCopyFile.CopyDirectory( const from_dir, to_dir : String ) : Boolean;
  function DoCopy( const from_dir, to_dir, path : String ) : Boolean;
  var
    SR : TSearchRec;
    Found : Integer;
    source, dest : String;
  begin
    result := False;
    source := from_dir + path;
    dest   := to_dir + path;
    if not DirectoryExists(source) then
      Exit;
    try
      ForceDirectories(dest);
      if not DirectoryExists(dest) then
        Exit;
      result := True;
      Found := FindFirst( source+'\'+Filter, faAnyFile, SR );
      try
        while Found = 0  do
          begin
            if (SR.Name <> '.') and (SR.Name <> '..') then
              begin
                if (SR.Attr and faDirectory) <> 0 then
                  begin
                    // Copy subdirectory
                    if Recursive then
                      result := result and DoCopy( from_dir, to_dir, path+'\'+SR.Name );
                  end
                else
                  begin
                    // Copy file
                    CopyFrom := source+'\'+SR.Name;
                    CopyTo   := dest+'\'+SR.Name;
                    CopyNow;
                  end;
              end;
            Found := FindNext( SR );
          end;
      finally
        FindClose(SR);
      end;
    except
    end;
  end;

begin
  PrecalcDirSize( from_dir );
  Start;
  try
    result := DoCopy( RemoveSlash(from_dir), RemoveSlash(to_dir), '' );
  finally
    Finish;
  end;
end;

function  TCustomCopyFile.GetDirectorySize( const dir : String ) : Integer;
  function DoCalcSize( const dir, path : String ) : Integer;
  var
    SR : TSearchRec;
    Found : Integer;
    source : String;
  begin
    result := 0;
    source := dir + path;
    if not DirectoryExists(source) then
      Exit;
    try
      result := 0;
      Found := FindFirst( source+'\'+Filter, faAnyFile, SR );
      try
        while Found = 0  do
          begin
            if (SR.Name <> '.') and (SR.Name <> '..') then
              begin
                WriteFileName( SR.Name );
                if (SR.Attr and faDirectory) <> 0 then
                  begin
                    // Copy subdirectory
                    if Recursive then
                      result := result + DoCalcSize( dir, path+'\'+SR.Name );
                  end
                else
                  begin
                    // Add file
                    Inc( Result, SR.Size );
                  end;
              end;
            Found := FindNext( SR );
          end;
      finally
        FindClose(SR);
      end;
    except
    end;
  end;

begin
  Start;
  if Assigned(FProgressForm) then
    FProgressForm.ProgressBar1.Visible := False;
  try
    result := DoCalcSize( RemoveSlash(dir), '' );
  finally
    if Assigned(FProgressForm) then
      FProgressForm.ProgressBar1.Visible := True;
    Finish;
  end;
end;

function  TCustomCopyFile.GetDirectoryCount( const dir : String ) : Integer;
  function DoCalcCount( const dir, path : String ) : Integer;
  var
    SR : TSearchRec;
    Found : Integer;
    source : String;
  begin
    result := 0;
    source := dir + path;
    if not DirectoryExists(source) then
      Exit;
    try
      result := 0;
      Found := FindFirst( source+'\'+Filter, faAnyFile, SR );
      try
        while Found = 0  do
          begin
            if (SR.Name <> '.') and (SR.Name <> '..') then
              begin
                WriteFileName( SR.Name );
                if (SR.Attr and faDirectory) <> 0 then
                  begin
                    // Copy subdirectory
                    if Recursive then
                      result := result + DoCalcCount( dir, path+'\'+SR.Name );
                  end
                else
                  begin
                    // Add file
                    Inc( Result );
                  end;
              end;
            Found := FindNext( SR );
          end;
      finally
        FindClose(SR);
      end;