Win32APIのCopyFileExのコールバックから無名メソッドを呼び出す

CopyFileEx and anonymous method (absolute)

// Create form 'TForm3', place 2 Edit, 2 Button and 1 Label.
unit Unit3;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, System.UITypes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
  Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm3 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FAborted: Boolean;
  public
    { Public 宣言 }
  end;

var
  Form3: TForm3;

implementation

{$R *.dfm}

{$WARN SYMBOL_PLATFORM OFF}

type
  TCopyProgressCallbackFunc = reference to function
                                (TotalFileSize: Int64;
                                 TotalBytesTransferred: Int64;
                                 StreamSize: Int64;
                                 StreamBytesTransferred: Int64;
                                 dwStreamNumber: DWORD;
                                 dwCallbackReason: DWORD;
                                 hSourceFile: THandle;
                                 hDestinationFile: THandle): DWORD;

function CopyProgressFunc(TotalFileSize: Int64;
                          TotalBytesTransferred: Int64;
                          StreamSize: Int64;
                          StreamBytesTransferred: Int64;
                          dwStreamNumber: DWORD;
                          dwCallbackReason: DWORD;
                          hSourceFile: THandle;
                          hDestinationFile: THandle;
                          lpData: Pointer): DWORD; stdcall;
var
  Callback: TCopyProgressCallbackFunc;
begin

  Callback := TCopyProgressCallbackFunc(lpData);
  Result := Callback(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;
  P: Pointer absolute Callback;
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;

  Win32Check(CopyFileEx(PChar(ExistingFileName),PChar(NewFileName),
             @CopyProgressFunc,P,@Canceled,CopyFlags));

end;

procedure TForm3.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 TForm3.Button2Click(Sender: TObject);
begin

  FAborted := True;

end;

end.

CopyFileEx and anonymous method (record)

// Create form 'TForm2', place 2 Edit, 2 Button and 1 Label.
unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, System.UITypes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
  Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm2 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Button1: TButton;
    Label1: TLabel;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    FAborted: Boolean;
  public
    { Public 宣言 }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

{$WARN SYMBOL_PLATFORM OFF}

type
  TCopyProgressCallbackFunc = reference to function
                                (TotalFileSize: Int64;
                                 TotalBytesTransferred: Int64;
                                 StreamSize: Int64;
                                 StreamBytesTransferred: Int64;
                                 dwStreamNumber: DWORD;
                                 dwCallbackReason: DWORD;
                                 hSourceFile: THandle;
                                 hDestinationFile: THandle): DWORD;

  TCopyProgressCallbackRec = record
    FCallback: TCopyProgressCallbackFunc;
  end;
  PCopyProgressCallbackRec = ^TCopyProgressCallbackRec;

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;

procedure TForm2.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 TForm2.Button2Click(Sender: TObject);
begin

  FAborted := True;

end;

end.