DelphiでファイルをコピーするときはWin32APIの
CopyFile関数 (
en)か、これをラッピングした(System.)IOUtilsの
TFile.Copyなどを使うのが普通ですが、大きめのファイルだったり遅いデバイスだったり、あるいはその両方で、ファイルコピーに
5秒以上かかるとWindowsに"応答なし"と判断されてしまうことになります。ファイルコピーを別スレッドで行ってもよいのですが(TFile.DoCopyの実装を見る限りPOSIX環境ではこれしかなさそう)、Windows環境であればWin32APIの
CopyFileEx関数 (
en)を使い、コールバック関数内で
Application.ProcessMessagesを呼び出すことでこの問題を回避することができます。ではまず(Winapi.)Windows.pas上のCopyFileExの定義を見てみましょう。
type
TFNProgressRoutine = TFarProc;
function CopyFileEx(lpExistingFileName, lpNewFileName: LPWSTR;
lpProgressRoutine: TFNProgressRoutine; lpData: Pointer; pbCancel: PBool;
dwCopyFlags: DWORD): BOOL; stdcall;
コールバック関数の型はTFNProgressRoutine=TFarProcと定義されていますが、TFarProcはというと、
TFarProc = Pointer;
となっており、やる気のなさ満点です(間違っちゃいないけど)。そこでまず
CopyProgressRoutineコールバック関数 (
en)の定義から用意します。
type
TCopyProgressRoutine = function (TotalFileSize: Int64;
TotalBytesTransferred: Int64;
StreamSize: Int64;
StreamBytesTransferred: Int64;
dwStreamNumber: DWORD;
dwCallbackReason: DWORD;
hSourceFile: THandle;
hDestinationFile: THandle;
lpData: Pointer): DWORD; stdcall;
これを使ってCopyFileEx関数を再定義します。
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;
これでファイルのコピー中に途中経過を表示できるようになります。またApplication.ProcessMessagesを呼び出すことでWindowsに"応答なし"と判定されることもなくなります(ただしイベントハンドラへの再入には十分注意が必要です)。
ここでは大きいファイルをコピーすることを想定しているため、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;
こんな感じです。コールバック関数がPROGRESS_CANCELを返してファイルコピーをキャンセルしたときはCopyFileExの戻値は0(エラー)となり、GetLastErrorは
ERROR_REQUEST_ABORTEDを返します。
さて、Delphi 2009以降でコールバックといえば無名メソッド、という連想が働きますが、それはまた
次回。
→
Win32APIのCopyFileExのコールバックを受け入れる (Gist)