////////////////////////////////////////////////////////////////////////////////
//
// 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;