copyfile.pas

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

    except
    end;
  end;

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

function  TCustomCopyFile.GetFileSize( const fileName : String ) : Integer;
begin
  Result := 0;
  if FileExists( fileName ) then
    begin
      try
        with TFileStream.Create( fileName, fmOpenRead or fmShareDenyNone) do
          try
            Result := Size;
          finally
            Free;
          end;
      except
      end;
    end;
end;

function TCustomCopyFile.DeleteDirectory( const dir : String ) : Boolean;

  procedure DoDeleteDirectory( const dir, path : String; var Result : Boolean );
  var
    SR : TSearchRec;
    Found : Integer;
    source : String;
  begin
    if not Result or not DirectoryExists( dir ) then
      Exit;

    source := dir + path;
    // Remove the files in the directory
    Found := FindFirst( source+'\*.*', faAnyFile, SR );
    try
      while Result and (Found = 0)  do
        begin
          SetProgress( MulDiv(FBytesCopied, 100, FBytesToCopy) );
          if (SR.Name<>'.') and (SR.Name <> '..') then
            begin
              WriteFileName( SR.Name );
              if (SR.Attr and faDirectory) <> 0 then
                begin
                  // Delete subdirectory
                  if Recursive then
                    DoDeleteDirectory( dir, path+'\'+SR.Name, Result );
                end
              else
                begin
                  // Remove attributes that could prevent us from deleting the file
                  FileSetAttr( source+'\'+SR.Name, FileGetAttr(source+'\'+SR.Name) and
                                                   not (faReadOnly or faHidden) );
                  // Delete file
                  if not DeleteFile( source+'\'+SR.Name ) then
                    result := False;
                end;
            end;
          Inc( FBytesCopied, SR.Size );
          Found := FindNext( SR );
        end;
    finally
      FindClose(SR);
    end;
    if Result then
      // Delete the empty directory
      result := result and RemoveDir( source );
  end;
begin
  result := True;
  PrecalcDirSize( dir );
  Start;
  try
    DoDeleteDirectory( RemoveSlash(dir), '', result );
  finally
    Finish;
  end;
end;

function TCustomCopyFile.IsDirectoryEmpty( const dir : String ) : Boolean;
var
  SR : TSearchRec;
  Found : Integer;
begin
  if not DirectoryExists( dir ) then
    raise Exception.CreateFmt('Le r閜ertoire "%s" n''existe pas',[dir]);
  result := True;
  Found := FindFirst( RemoveSlash(dir)+'\*.*', faAnyFile, SR );
  try
    while Found = 0  do
      begin
        if (SR.Name<>'.') and (SR.Name <> '..') then
          begin
            result := False;
            Break;
          end;
        Found := FindNext( SR );
      end;
  finally
    FindClose(SR);
  end;
end;

// This function checks if a Directory is in use.
// It travels each subdirectory and tries to open each file
// in exclusive mode. If it fails, it means that someone has
// already locked this file, and it won't be possible to delete
// the directory containing it.

function  TCustomCopyFile.IsDirectoryInUse( const dir : String ) : Boolean;
  function DoIsDirectoryInUse( const dir, path : String ) : Boolean;
  var
    SR : TSearchRec;
    Found : Integer;
    source : String;
    f : Integer;
  begin
    source := dir + path;
    if not DirectoryExists(source) then
      raise Exception.CreateFmt(sDirectoryDoesNotExist,[source]);
    result := True;
    Found := FindFirst( source+'\*.*', faAnyFile, SR );
    try
      while (Found = 0) and Result  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 and DoIsDirectoryInUse( dir, path+'\'+SR.Name );
                end
              else
                begin
                  // Check if the file is locked
                  f := FileOpen( source+'\'+SR.Name, fmShareExclusive );
                  if f < 0 then
                    Result := False
                  else
                    FileClose(f);
                end;
            end;
          Found := FindNext( SR );
        end;
    finally
      FindClose(SR);
    end;
  end;

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

function  TCustomCopyFile.FindFile( const FileName, DirectoryStart : String ) : Boolean;
  function DoFindFile( const dir, path : String ) : Boolean;
  var
    SR : TSearchRec;
    Found : Integer;
    source : String;
  begin
    source := dir + path;
    if not DirectoryExists(source) then
      raise Exception.CreateFmt(sDirectoryDoesNotExist,[source]);
    result := True;
    Found := FindFirst( source+'\*.*', faAnyFile, SR );
    try
      while (Found = 0) and Result  do
        begin
          if (SR.Name <> '.') and (SR.Name <> '..') then
            begin
              WriteFileName( SR.Name );
              if SR.Name = FileName then
                begin
                  Result := False;
                  Break;
                end;
              if (SR.Attr and faDirectory) <> 0 then
                begin
                  // Copy subdirectory
                  if Recursive then
                    result := result and DoFindFile( dir, path+'\'+SR.Name );
                end;
            end;
          Found := FindNext( SR );
        end;
    finally
      FindClose(SR);
    end;
  end;

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

procedure TCustomCopyFile.CopyFilesWithJoker( const FileName, DestDirectory : String );
var
  SR : TSearchRec;
  Found : Integer;
  dest : String;
begin
  Start;
  try
    dest := AppendSlash(DestDirectory);
    Found := FindFirst( FileName, faAnyFile, SR );
    try
      while (Found = 0) do
        begin
          if (SR.Name <> '.') and (SR.Name <> '..') then
            begin
              if (SR.Attr and faDirectory) = 0 then
                begin
                  WriteFileName( SR.Name );
                  CopyFrom := ExtractFilePath(FileName)+SR.Name;
                  CopyTo   := dest+SR.Name;
                  CopyNow;
                end;
            end;
          Found := FindNext( SR );
        end;
    finally
      FindClose(SR);
    end;
  finally
    Finish;
  end;
end;

procedure TCustomCopyFile.CopyFiles( AList : TStrings; const DestDirectory : String );
var
  i : Integer;
begin
  if not DirectoryExists(DestDirectory) then
    raise Exception.CreateFmt(sDirectoryDoesNotExist,[DestDirectory]);
  Start;
  try
    for i := 0 to AList.Count - 1 do
      begin
        if AList.Strings[i] <> '' then
          CopyFilesWithJoker( AList.Strings[i], DestDirectory );
      end;
  finally
    Finish;
  end;
end;

function TCustomCopyFile.DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  // make it upper case

  if Drive in ['a'..'z'] then Dec(Drive, $20);
  // make sure it's a letter
  if not (Drive in ['A'..'Z']) then
    raise EConvertError.Create('Not a valid drive ID');
  // turn off critical errors
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    // drive 1 = a, 2 = b, 3 = c, etc.
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
  finally
    // restore old error mode
    SetErrorMode(ErrorMode);
  end;
end;


end.