type
TFNProgressRoutine = TFarProc;
function CopyFileEx(lpExistingFileName, lpNewFileName: LPWSTR;
lpProgressRoutine: TFNProgressRoutine; lpData: Pointer; pbCancel: PBool;
dwCopyFlags: DWORD): BOOL; stdcall;
TFarProc = Pointer;
type
TCopyProgressRoutine = function (TotalFileSize: Int64;
TotalBytesTransferred: Int64;
StreamSize: Int64;
StreamBytesTransferred: Int64;
dwStreamNumber: DWORD;
dwCallbackReason: DWORD;
hSourceFile: THandle;
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
function CopyFileEx(lpExistingFileName: PChar;
lpNewFileName: PChar;
lpProgressRoutine: TCopyProgressRoutine;
lpData: Pointer;
pbCancel: PBool;
dwCopyFlags: DWORD): BOOL; stdcall; external kernel32
{$IFDEF UNICODE}
name 'CopyFileExW';
{$ELSE}
name 'CopyFileExA';
{$ENDIF}
{$EXTERNALSYM CopyFileEx}
これらの定義を使ってファイルをコピーしてみましょう。まずフォーム上にコピー元ファイル名とコピー先ファイル名を入力するためのEditを2つとコピー開始のButton、途中経過表示用のLabelを配置します。
{$WARN SYMBOL_PLATFORM OFF}
const
COPY_FILE_NO_BUFFERING = $00001000;
function CopyProgressFunc(TotalFileSize: Int64;
TotalBytesTransferred: Int64;
StreamSize: Int64;
StreamBytesTransferred: Int64;
dwStreamNumber: DWORD;
dwCallbackReason: DWORD;
hSourceFile: THandle;
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
var
TBT: Extended;
TFS: Extended;
begin
TFS := TotalFileSize;
TBT := TotalBytesTransferred;
with TObject(lpData) as TForm1 do
begin
if (TotalFileSize = 0) or (TotalBytesTransferred = 0) then
begin
Label1.Caption := '';
end
else
begin
Label1.Caption := Format('%.0n / %.0n bytes',[TBT,TFS]);
end;
end;
Application.ProcessMessages;
Result := PROGRESS_CONTINUE;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Canceled: BOOL;
CopyFlags: DWORD;
begin
Button1.Enabled := False;
try
Canceled := False;
CopyFlags := COPY_FILE_FAIL_IF_EXISTS;
if CheckWin32Version(6,0) then
begin
CopyFlags := CopyFlags or COPY_FILE_NO_BUFFERING;
end;
Win32Check(CopyFileEx(PChar(Edit1.Text),PChar(Edit2.Text),
CopyProgressFunc,Self,@Canceled,CopyFlags));
finally
Button1.Enabled := True;
end;
end;
ここでは大きいファイルをコピーすることを想定しているため、Windows Vista以降ではdwCopyFlagsにCOPY_FILE_NO_BUFFERINGを追加指定しています(COPY_FILE_NO_BUFFERINGには功罪両面ありますが)。またファイルの上書きを許す場合はCopyFlagsにCOPY_FILE_FAIL_IF_EXISTSではなくて0を指定します(CopyFlagsにCOPY_FILE_FAIL_IF_EXISTSを指定したときにコピー先ファイルが存在しているとCopyFileExの戻値は0となり、GetLastError (en)はERROR_FILE_EXISTSを返します)。
さらにコピーの途中でキャンセルできるようにしてみます。フォームにキャンセル用のButtonと、privateメンバにBoolean型のフィールドFAbortedを追加します。
function CopyProgressFunc(TotalFileSize: Int64;
TotalBytesTransferred: Int64;
StreamSize: Int64;
StreamBytesTransferred: Int64;
dwStreamNumber: DWORD;
dwCallbackReason: DWORD;
hSourceFile: THandle;
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
var
TBT: Extended;
TFS: Extended;
begin
TFS := TotalFileSize;
TBT := TotalBytesTransferred;
with TObject(lpData) as TForm1 do
begin
if (TotalFileSize = 0) or (TotalBytesTransferred = 0) then
begin
Label1.Caption := '';
end
else
begin
Label1.Caption := Format('%.0n / %.0n bytes',[TBT,TFS]);
end;
Result := PROGRESS_CONTINUE;
Application.ProcessMessages;
if FAborted = True then
begin
Result := PROGRESS_CANCEL;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Canceled: BOOL;
CopyFlags: DWORD;
begin
FAborted := False;
Button1.Enabled := False;
try
Canceled := False;
CopyFlags := COPY_FILE_FAIL_IF_EXISTS;
if CheckWin32Version(6,0) then
begin
CopyFlags := CopyFlags or COPY_FILE_NO_BUFFERING;
end;
Win32Check(CopyFileEx(PChar(Edit1.Text),PChar(Edit2.Text),
CopyProgressFunc,Self,@Canceled,CopyFlags));
finally
Button1.Enabled := True;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
FAborted := True;
end;
さて、Delphi 2009以降でコールバックといえば無名メソッド、という連想が働きますが、それはまた次回。
→Win32APIのCopyFileExのコールバックを受け入れる (Gist)
