まず無名メソッドの定義から。
type TCopyProgressCallbackFunc = reference to function (TotalFileSize: Int64; TotalBytesTransferred: Int64; StreamSize: Int64; StreamBytesTransferred: Int64; dwStreamNumber: DWORD; dwCallbackReason: DWORD; hSourceFile: THandle; hDestinationFile: THandle): DWORD;無名メソッドは実際にはコンパイラが自動的に生成する(メンバにメソッドInvokeだけを持つ)TInterfacedObjectの派生クラスのインスタンスなので、これをCopyFileEx関数の第4パラメータ(lpData)経由でコールバック関数に渡して、そこから無名メソッドを呼び出せばいい…はずなのですが、無名メソッドそのままだとどうやってもうまくいかないので、無名メソッドをレコード型の変数に格納してそのアドレスを受け渡すようにします。そのレコード型の定義は
type TCopyProgressCallbackRec = record FCallback: TCopyProgressCallbackFunc; end; PCopyProgressCallbackRec = ^TCopyProgressCallbackRec;となります。このレコード型のポインタ(PCopyProgressCallbackRec)を使い、CopyFileEx関数のコールバックでは
function CopyProgressFunc(TotalFileSize: Int64; TotalBytesTransferred: Int64; StreamSize: Int64; StreamBytesTransferred: Int64; dwStreamNumber: DWORD; dwCallbackReason: DWORD; hSourceFile: THandle; hDestinationFile: THandle; lpData: Pointer): DWORD; stdcall; var PCallback: PCopyProgressCallbackRec; begin PCallback := PCopyProgressCallbackRec(lpData); Result := PCallback^.FCallback(TotalFileSize, TotalBytesTransferred, StreamSize, StreamBytesTransferred, dwStreamNumber, dwCallbackReason, hSourceFile, hDestinationFile); end;と無名メソッドを呼び出すようにします。あとはコールバックとして無名メソッドを受け取るファイルコピー関数を作成します。
procedure CopyFile(const ExistingFileName: String; const NewFileName: String; FailIfExists: Boolean; NoBuffering: Boolean; Callback: TCopyProgressCallbackFunc); var Canceled: BOOL; CopyFlags: DWORD; CallbackRec: TCopyProgressCallbackRec; begin Canceled := False; CopyFlags := 0; if FailIfExists = True then begin CopyFlags := CopyFlags or COPY_FILE_FAIL_IF_EXISTS; end; if (NoBuffering = True) and CheckWin32Version(6,0) then begin CopyFlags := CopyFlags or COPY_FILE_NO_BUFFERING; end; CallbackRec.FCallback := Callback; Win32Check(CopyFileEx(PChar(ExistingFileName),PChar(NewFileName), @CopyProgressFunc,@CallbackRec,@Canceled,CopyFlags)); end;前回同様にフォーム上にコピー元ファイル名とコピー先ファイル名を入力するためのEditを2つとコピー開始/コピー中断のButton、途中経過表示用のLabelを配置して、コピー開始のButtonのOnClickイベントとコピー中断のButtonのOnClickイベントを記述します。
procedure TForm1.Button1Click(Sender: TObject); begin FAborted := False; Button1.Enabled := False; try CopyFile(Edit1.Text,Edit2.Text,True,True, function (TotalFileSize: Int64; TotalBytesTransferred: Int64; StreamSize: Int64; StreamBytesTransferred: Int64; dwStreamNumber: DWORD; dwCallbackReason: DWORD; hSourceFile: THandle; hDestinationFile: THandle): DWORD var TBT: Extended; TFS: Extended; begin TFS := TotalFileSize; TBT := TotalBytesTransferred; 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 FAborted := False; if MessageDlg('ファイルコピーを中断しますか?', mtConfirmation,[mbYes,mbNo],0) = mrYes then begin Result := PROGRESS_CANCEL; end; end; end); finally Button1.Enabled := True; end; end; procedure TForm1.Button2Click(Sender: TObject); begin FAborted := True; end;ここではコピー中止のButtonをクリックすると中断するかどうか確認するダイアログを表示するようにしています。
→Win32APIのCopyFileExのコールバックから無名メソッドを呼び出す (Gist)
0 件のコメント:
コメントを投稿