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)
0 件のコメント:
コメントを投稿