CopyFileExを使う

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;

Object Pascal

コールバック関数の型はTFNProgressRoutine=TFarProcと定義されていますが、TFarProcはというと、

TFarProc = Pointer;

Object Pascal

となっており、やる気のなさ満点です(間違っちゃいないけど)。そこでまず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;

Object Pascal

これを使って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}

Object Pascal

これらの定義を使ってファイルをコピーしてみましょう。まずフォーム上にコピー元ファイル名とコピー先ファイル名を入力するための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;

Object Pascal

これでファイルのコピー中に途中経過を表示できるようになります。また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;

Object Pascal

こんな感じです。コールバック関数がPROGRESS_CANCELを返してファイルコピーをキャンセルしたときはCopyFileExの戻値は0(エラー)となり、GetLastErrorはERROR_REQUEST_ABORTEDを返します。

さて、Delphi 2009以降でコールバックといえば無名メソッド、という連想が働きますが、それはまた次回。

→Win32APIのCopyFileExのコールバックを受け入れる (Gist)