Kopierstatus in eigener ProgressBar?

[NicoDE]

Alternative für Copy 'n Paste Liebhaber (die gerne meine Bugs fixen )

Delphi-Quellcode:

////////////////////////////////////////////////////////////////////////////////
//
// CopyFileEx Wrapper
//

type
  PProgressRoutine = ^TProgressRoutine;
  TProgressRoutine = function(TotalFileSize, TotalBytesTransferred, StreamSize,
    StreamBytesTransferred: TLargeInteger; StreamNumber, CallbackReason: DWORD;
    SourceFile, DestinationFile: THandle; Data: Pointer): DWORD; stdcall;

type
  TFNCopyFileExA = function(ExistingFileName, NewFileName: LPCSTR;
    ProgressRoutine: TProgressRoutine; Data: Pointer; Cancel: PBOOL;
    CopyFlags: DWORD): BOOL; stdcall;
  TFNCopyFileExW = function(ExistingFileName, NewFileName: LPCWSTR;
    ProgressRoutine: TProgressRoutine; Data: Pointer; Cancel: PBOOL;
    CopyFlags: DWORD): BOOL; stdcall;
{$IFDEF UNICODE}
  TFNCopyFileEx = TFNCopyFileExW;
{$ELSE}
  TFNCopyFileEx = TFNCopyFileExA;
{$ENDIF UNICODE}

var
  FNCopyFileExW: TFNCopyFileExW;

function MyCopyFileExW(ExistingFileName, NewFileName: LPCWSTR;
  ProgressRoutine: TProgressRoutine; Data: Pointer; Cancel: PBOOL;
  CopyFlags: DWORD): BOOL; stdcall;
var
  FindFile: THandle;
  FindData: TWin32FindDataW;
  FileSize: TLargeInteger;
  Progress: DWORD;
begin
  Result := False;
  if not Assigned(FNCopyFileExW) then
    FNCopyFileExW := TFNCopyFileExW(
      GetProcAddress(GetModuleHandleW(kernel32), 'CopyFileExW'));
  if Assigned(FNCopyFileExW) then
    Result := FNCopyFileExW(ExistingFileName, NewFileName, ProgressRoutine,
      Data, Cancel, CopyFlags);
  if not Result and (ERROR_CALL_NOT_IMPLEMENTED = GetLastError) then
  begin
    FindFile := FindFirstFileW(ExistingFileName, FindData);
    if FindFile <> INVALID_HANDLE_VALUE then
      try
        with FindData do
          FileSize := nFileSizeHigh * (Int64(MAXDWORD) + 1) + nFileSizeLow;
        if Assigned(ProgressRoutine) then
          Progress := ProgressRoutine(FileSize, 0, FileSize, 0, 0,
            CALLBACK_STREAM_SWITCH, INVALID_HANDLE_VALUE, INVALID_HANDLE_VALUE,
            nil)
        else
          Progress := PROGRESS_CONTINUE;
        if Progress in [PROGRESS_CONTINUE, PROGRESS_QUIET] then
        begin
          Result := CopyFileW(ExistingFileName, NewFileName,
            CopyFlags and COPY_FILE_FAIL_IF_EXISTS = COPY_FILE_FAIL_IF_EXISTS);
          if Result and Assigned(ProgressRoutine) and
            (Progress <> PROGRESS_QUIET) then
            if PROGRESS_CANCEL = ProgressRoutine(FileSize, FileSize, FileSize,
              FileSize, 0, CALLBACK_CHUNK_FINISHED, INVALID_HANDLE_VALUE,
              INVALID_HANDLE_VALUE, nil) then
            begin
              DeleteFileW(NewFileName);
              Result := False;
            end;
        end;
      finally
        Windows.FindClose(FindFile);
      end;
  end;
end;

var
  FNCopyFileExA: TFNCopyFileExA;

function MyCopyFileExA(ExistingFileName, NewFileName: LPCSTR;
  ProgressRoutine: TProgressRoutine; Data: Pointer; Cancel: PBOOL;
  CopyFlags: DWORD): BOOL; stdcall;
var
  FindFile: THandle;
  FindData: TWin32FindDataA;
  FileSize: TLargeInteger;
  Progress: DWORD;
begin
  Result := False;
  if not Assigned(FNCopyFileExA) then
    FNCopyFileExA := TFNCopyFileExA(
      GetProcAddress(GetModuleHandleA(kernel32), 'CopyFileExA'));
  if Assigned(FNCopyFileExA) then
    Result := FNCopyFileExA(ExistingFileName, NewFileName, ProgressRoutine,
      Data, Cancel, CopyFlags);
  if not Result and (ERROR_CALL_NOT_IMPLEMENTED = GetLastError) then
  begin
    FindFile := FindFirstFileA(ExistingFileName, FindData);
    if FindFile <> INVALID_HANDLE_VALUE then
      try
        with FindData do
          FileSize := nFileSizeHigh * (Int64(MAXDWORD) + 1) + nFileSizeLow;
        if Assigned(ProgressRoutine) then
          Progress := ProgressRoutine(FileSize, 0, FileSize, 0, 0,
            CALLBACK_STREAM_SWITCH, INVALID_HANDLE_VALUE, INVALID_HANDLE_VALUE,
            nil)
        else
          Progress := PROGRESS_CONTINUE;
        if Progress in [PROGRESS_CONTINUE, PROGRESS_QUIET] then
        begin
          Result := CopyFileA(ExistingFileName, NewFileName,
            CopyFlags and COPY_FILE_FAIL_IF_EXISTS = COPY_FILE_FAIL_IF_EXISTS);
          if Result and Assigned(ProgressRoutine) and
            (Progress <> PROGRESS_QUIET) then
            if PROGRESS_CANCEL = ProgressRoutine(FileSize, FileSize, FileSize,
              FileSize, 0, CALLBACK_CHUNK_FINISHED, INVALID_HANDLE_VALUE,
              INVALID_HANDLE_VALUE, nil) then
            begin
              DeleteFileA(NewFileName);
              Result := False;
            end;
        end;
      finally
        Windows.FindClose(FindFile);
      end;
  end;
end;

const
{$IFDEF UNICODE}
  MyCopyFileEx: TFNCopyFileEx = MyCopyFileExW;
{$ELSE}
  MyCopyFileEx: TFNCopyFileEx = MyCopyFileExA;
{$ENDIF UNICODE}

////////////////////////////////////////////////////////////////////////////////
//
//  CopyFileWithProgress
//

type
  PMyCopyFileExRoutineData = ^TMyCopyFileExRoutineData;
  TMyCopyFileExRoutineData = record
    ProgressBar    : TProgressBar;
    ProcessMessages: Boolean;
  end;

function MyCopyFileExRoutine(TotalFileSize, TotalBytesTransferred, StreamSize,
  StreamBytesTransferred: TLargeInteger; StreamNumber, CallbackReason: DWORD;
  SourceFile, DestinationFile: THandle; Data: Pointer): DWORD; stdcall;
begin
  if Assigned(Data) then
    with PMyCopyFileExRoutineData(Data)^ do
    begin
      if Assigned(ProgressBar) then
        with ProgressBar do
          case CallbackReason of
            CALLBACK_STREAM_SWITCH:
              Position := Min;
            CALLBACK_CHUNK_FINISHED:
              if StreamSize > 0 then
                Position := Min +
                  StreamBytesTransferred * (Max - Min) div StreamSize;
          end;
      if ProcessMessages then
        Application.ProcessMessages;
    end;
  Result := PROGRESS_CONTINUE;
end;

function MyCopyFileWithProgress(const ExistingFileName, NewFileName: string;
  ProgressBar: TProgressBar; FailIfExist: Boolean;
  ProcessMessages: Boolean = False): Boolean;
var
  CopyFlags: DWORD;
  MyCopyDat: TMyCopyFileExRoutineData;
begin
  if FailIfExist then
    CopyFlags := COPY_FILE_FAIL_IF_EXISTS
  else
    CopyFlags := 0;
  MyCopyDat.ProgressBar     := ProgressBar;
  MyCopyDat.ProcessMessages := ProcessMessages;
  Result := MyCopyFileEx(PChar(ExistingFileName), PChar(NewFileName),
    MyCopyFileExRoutine, @MyCopyDat, nil, CopyFlags);
end;

// Test

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute and SaveDialog1.Execute then
  begin
    Button1.Enabled := False;
    try
      if MyCopyFileWithProgress(OpenDialog1.FileName, SaveDialog1.FileName,
        ProgressBar1, False, True) then
        ShowMessage('done')
      else
        ShowMessage(SysErrorMessage(GetLastError));
    finally
      Button1.Enabled := True;
    end;
  end;
end;