Win32APIのSetPriorityClass関数でプロセスの優先順位を指定する

実行中のプロセスの優先順位クラス (Priority class)を取得/設定するにはWin32APIのGetPriorityClass関数 (en)およびSetPriorityClass関数 (en)を使用します。このとき自プロセスの優先順位クラスを指定するのであればGetCurrentProcess関数 (en)で取得した擬似ハンドルを使用することができます(他のプロセスの優先順位クラスの場合、PROCESS_SET_INFORMATIONアクセス権を持ったプロセスハンドルが必要です)。

まずBELOW_NORMAL_PRIORITY_CLASSとABOVE_NORMAL_PRIORITY_CLASSの定義を追加します。

{$IF RTLVersion < 24}
const
  BELOW_NORMAL_PRIORITY_CLASS = $00004000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
  ABOVE_NORMAL_PRIORITY_CLASS = $00008000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
{$IFEND}

Object Pascal

フォームに優先順位クラスを表示するComboBox(StyleはcsDropDownList)と優先順位クラスを取得、設定するButtonを配置し、フォームのOnCreateイベントでComboBoxに優先順位クラスの表示文字列と値を格納します。

procedure TForm1.FormCreate(Sender: TObject);
begin

  with ComboBox1.Items do
  begin
    BeginUpdate;
    try
      Clear;
      AddObject(Format('%s (0x%8.8X)',['IDLE',IDLE_PRIORITY_CLASS]),
                TObject(IDLE_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['BELOW_NORMAL',BELOW_NORMAL_PRIORITY_CLASS]),
                TObject(BELOW_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['NORMAL',NORMAL_PRIORITY_CLASS]),
                TObject(NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['ABOVE_NORMAL',ABOVE_NORMAL_PRIORITY_CLASS]),
                TObject(ABOVE_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['HIGH',HIGH_PRIORITY_CLASS]),
                TObject(HIGH_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['REALTIME',REALTIME_PRIORITY_CLASS]),
                TObject(REALTIME_PRIORITY_CLASS));

    finally
      EndUpdate;
    end;
  end;

end;

Object Pascal

自プロセスの優先順位クラスを取得して表示します。

{$WARN SYMBOL_PLATFORM OFF}

procedure TForm1.Button1Click(Sender: TObject);
var
  PriorityClass: DWORD;
  I: Integer;
begin

  PriorityClass := GetPriorityClass(GetCurrentProcess);

  with ComboBox1 do
  begin
    for I := 0 to Items.Count - 1 do
    begin
      if DWORD(Items.Objects[I]) = PriorityClass then
      begin
        ItemIndex := I;
        Exit;
      end;
    end;

    ItemIndex := -1;
  end;

end;

Object Pascal

今度は選択された優先順位クラスを自プロセスに設定します。

procedure TForm1.Button2Click(Sender: TObject);
var
  PriorityClass: DWORD;
begin

  with ComboBox1 do
  begin
    if ItemIndex < 0 then
    begin
      Exit;
    end;

    PriorityClass := DWORD(Items.Objects[ItemIndex]);
    Win32Check(SetPriorityClass(GetCurrentProcess,PriorityClass));
  end;

end;

Object Pascal

Windowsにおけるスケジューリングのメカニズムは非常に複雑で、優先順位が実行中に動的に変更されるなど、単純に優先順位クラスなどで決まるわけではありません。このあたりをきちんと理解するためにはAdvanced Windows 第5版 上 (amazon)の"7.8 スレッドの優先度"、"7.9 優先度クラスの概要"、"7.10 プログラミングの優先度"やインサイドWindows 第6版 上 (amazon) の"5.7 スレッドのスケジューリング"などを読むことをお勧めします。

→GetPriorityClassとSetPriorityClassで優先順位クラスを取得/設定する (Gist)

CreateProcessで優先順位を指定してプログラムを起動する

優先順位クラス (Priority class)を指定してプロセスを起動するにはWin32APIのCreateProcess関数 (en)の第6パラメータ(dwCreationFlags)に優先順位クラスを指定します。

Delphi XE2およびそれ以前のバージョンではWindows.pasにBELOW_NORMAL_PRIORITY_CLASSとABOVE_NORMAL_PRIORITY_CLASSが定義されていないので、まずこれらを定義します。

{$IF RTLVersion < 24}
const
  BELOW_NORMAL_PRIORITY_CLASS = $00004000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
  ABOVE_NORMAL_PRIORITY_CLASS = $00008000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
{$IFEND}

Object Pascal

フォームにEditとComboBox、Buttonをひとつずつ配置し、フォームのOnCreateイベントでEditとComboBoxに値を格納します。

procedure TForm1.FormCreate(Sender: TObject);
begin

  Edit1.Text := '%windir%\notepad.exe';

  with ComboBox1.Items do
  begin
    BeginUpdate;
    try
      Clear;
      AddObject(Format('%s (0x%8.8X)',['IDLE',IDLE_PRIORITY_CLASS]),
                TObject(IDLE_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['BELOW_NORMAL',BELOW_NORMAL_PRIORITY_CLASS]),
                TObject(BELOW_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['NORMAL',NORMAL_PRIORITY_CLASS]),
                TObject(NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['ABOVE_NORMAL',ABOVE_NORMAL_PRIORITY_CLASS]),
                TObject(ABOVE_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['HIGH',HIGH_PRIORITY_CLASS]),
                TObject(HIGH_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['REALTIME',REALTIME_PRIORITY_CLASS]),
                TObject(REALTIME_PRIORITY_CLASS));

    finally
      EndUpdate;
    end;
  end;

  with ComboBox1 do
  begin
    ItemIndex := Items.IndexOfObject(TObject(NORMAL_PRIORITY_CLASS));
  end;

end;

Object Pascal

優先順位を指定してプロセスを起動します。

{$WARN SYMBOL_PLATFORM OFF}

procedure TForm1.Button1Click(Sender: TObject);
var
  ApplicationName: String;
  CreationFlags: DWORD;
  StartupInfo: TStartupInfo;
  ProcessInformation: TProcessInformation;
  Length: Integer;
begin

  Length := ExpandEnvironmentStrings(PChar(Edit1.Text),nil,0);
  SetLength(ApplicationName,Length);
  ExpandEnvironmentStrings(PChar(Edit1.Text),PChar(ApplicationName),Length);
  UniqueString(ApplicationName);

  with ComboBox1 do
  begin
    if ItemIndex < 0 then
    begin
      Exit;
    end;

    CreationFlags := DWORD(Items.Objects[ItemIndex]);
  end;

  FillChar(StartupInfo,SizeOf(StartupInfo),0);
  StartupInfo.cb := SizeOf(StartupInfo);

  FillChar(ProcessInformation,SizeOf(ProcessInformation),0);

  Win32Check(CreateProcess(PChar(ApplicationName),nil,nil,nil,False,
                           CreationFlags,nil,nil,
                           StartupInfo,ProcessInformation));

  CloseHandle(ProcessInformation.hProcess);
  CloseHandle(ProcessInformation.hThread);

end;

Object Pascal

ここではEditに入力された起動対象プログラムに%windir%などの環境変数を使用することを前提としているため、Win32APIのExpandEnvironmentStrings関数 (en)で展開しています。

→優先順位クラスを指定してプロセスを起動する (Gist)

コマンドプロンプトのSTARTコマンドで優先順位を指定してプログラムを起動する

プログラムを実行するときに、そのプロセスの優先順位クラス (Priority class)を外部から指定するには、コマンドプロンプト(cmd.exe)のSTARTコマンドを使用します。

start /<PriorityClass> <program>

Textfile

ここで/<PriorityClass>には

/REALTIME
REALTIME_PRIORITY_CLASS (リアルタイム/24)
/HIGH
HIGH_PRIORITY_CLASS (高/13)
/ABOVENORMAL
ABOVE_NORMAL_PRIORITY_CLASS (通常以上/10)
/NORMAL
NORMAL_PRIORITY_CLASS (通常/8)
/BELOWNORMAL
BELOW_NORMAL_PRIORITY_CLASS (通常以下/6)
/LOW
IDLE_PRIORITY_CLASS (低/4)

を指定可能です(括弧内の数字は同一の優先順位クラス内の相対的な優先順位を表す優先順位レベル (Priority level)をTHREAD_PRIORITY_NORMALに指定したときのベースプライオリティ)。

[書籍]たのしいバイナリの歩き方

紀伊國屋書店 新宿本店で

たのしいバイナリの歩き方 (amazon)/愛甲健二著/技術評論社/ISBN 978-4-7741-5918-8/2,919円

を購入。

Microsoft Monthly Update 2013/08

今日はMicrosoftのセキュリティアップデートの日です。
MS13-059
MS13-060
MS13-061
MS13-062
MS13-063
MS13-064
MS13-065
MS13-066

列挙型と列挙子名(文字列)または整数の相互変換(ジェネリックス版)

しばらく前にジェネリックス版の列挙型と列挙子名の相互変換について書きましたが、これを多少改善してみました。まず整数から列挙値への変換を追加しました(GetEnumValueのInteger引数版)。整数から列挙値への変換は普通は型キャストですませてしまいますが、これだと(デフォルトの設定である){$RANGECHECKS OFF}の状態で範囲外の値が格納されることを防げないため、列挙型の最小値、最大値の確認を行うようにしています。あとはエラーが発生したときに例外を生成するのではなく戻値で区別する関数(Try...)を追加しました。

uses
  TypInfo, SysUtils, SysConst;

type
  TEnumHelper = record
    class function TryGetEnumName<T: record>(Value: T; out S: String): Boolean; static;
    class function GetEnumName<T: record>(Value: T): String; static;
    class function TryGetEnumValue<T: record>(const Name: String; out Enum: T): Boolean; overload; static;
    class function GetEnumValue<T: record>(const Name: String): T; overload; static;
    class function TryGetEnumValue<T: record>(Value: Integer; out Enum: T): Boolean; overload; static;
    class function GetEnumValue<T: record>(Value: Integer): T; overload; static;
  end;

class function TEnumHelper.TryGetEnumName<T>(Value: T; out S: String): Boolean;
var
  P: PTypeInfo;
  IValue: Integer;
begin

  Result := False;
  S := '';

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    Exit;
  end;

  IValue := 0;
  Move(Value,IValue,SizeOf(T));
  S := TypInfo.GetEnumName(P,IValue);
  Result := True;

end;

class function TEnumHelper.GetEnumName<T>(Value: T): String;
var
  P: PTypeInfo;
  IValue: Integer;
begin

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    raise EInvalidOpException.CreateRes(@SVarNotImplemented);
  end;

  IValue := 0;
  Move(Value,IValue,SizeOf(T));
  Result := TypInfo.GetEnumName(P,IValue);

end;

class function TEnumHelper.TryGetEnumValue<T>(const Name: String; out Enum: T): Boolean;
var
  P: PTypeInfo;
  IValue: Integer;
begin

  Result := False;
  Enum := Default(T);

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    Exit;
  end;

  IValue := TypInfo.GetEnumValue(P,Name);

  with GetTypeData(P)^ do
  begin
    if (IValue < MinValue) or (IValue > MaxValue) then
    begin
      Exit;
    end;
  end;

  Move(IValue,Enum,SizeOf(T));
  Result := True;

end;

class function TEnumHelper.GetEnumValue<T>(const Name: String): T;
var
  P: PTypeInfo;
  IValue: Integer;
begin

  Result := Default(T);

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    raise EInvalidOpException.CreateRes(@SVarNotImplemented);
  end;

  IValue := TypInfo.GetEnumValue(P,Name);

  with GetTypeData(P)^ do
  begin
    if (IValue < MinValue) or (IValue > MaxValue) then
    begin
      raise ERangeError.CreateRes(@SRangeError);
    end;
  end;

  Move(IValue,Result,SizeOf(T));

end;

class function TEnumHelper.TryGetEnumValue<T>(Value: Integer; out Enum: T): Boolean;
var
  P: PTypeInfo;
begin

  Result := False;
  Enum := Default(T);

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    Exit;
  end;

  with GetTypeData(P)^ do
  begin
    if (Value < MinValue) or (Value > MaxValue) then
    begin
      Exit;
    end;
  end;

  Move(Value,Enum,SizeOf(T));
  Result := True;

end;

class function TEnumHelper.GetEnumValue<T>(Value: Integer): T;
var
  P: PTypeInfo;
begin

  Result := Default(T);

  P := TypeInfo(T);
  if (P = nil) or (P^.Kind <> tkEnumeration) then
  begin
    raise EInvalidOpException.CreateRes(@SVarNotImplemented);
  end;

  with GetTypeData(P)^ do
  begin
    if (Value < MinValue) or (Value > MaxValue) then
    begin
      raise ERangeError.CreateRes(@SRangeError);
    end;
  end;

  Move(Value,Result,SizeOf(T));

end;

Object Pascal

こんな感じで使います。

var
  S: String;
begin

  if TEnumHelper.TryGetEnumName(0,S) = True then  // Error (0 is not enumeration)
  begin
    Label1.Caption := S;
  end
  else
  begin
    Label1.Caption := '(Error)';
  end;

  S := TEnumHelper.GetEnumName(taLeftJustify);  // taLeftJustify -> 'taLeftJustify'
  Label2.Caption := S;

  S := TEnumHelper.GetEnumName(False);  // False -> 'False'
  Label3.Caption := S;

end;

Object Pascal

元ねたはDelphi XE2 Foundations。

→列挙型と列挙子名(文字列)または整数の相互変換(ジェネリックス版) (Gist)

CopyFileExを無名メソッドで使う

前回はWin32APIのCopyFileEx関数 (en)でファイルをコピーする処理を作成しましたが、Delphi 2009以降ではやはりコールバックを無名メソッドで記述したいところです。ということでCopyFileExの無名メソッド版です。

まず無名メソッドの定義から。

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

Object Pascal

無名メソッドは実際にはコンパイラが自動的に生成する(メンバにメソッドInvokeだけを持つ)TInterfacedObjectの派生クラスのインスタンスなので、これをCopyFileEx関数の第4パラメータ(lpData)経由でコールバック関数に渡して、そこから無名メソッドを呼び出せばいい…はずなのですが、無名メソッドそのままだとどうやってもうまくいかないので、無名メソッドをレコード型の変数に格納してそのアドレスを受け渡すようにします。そのレコード型の定義は

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

Object Pascal

となります。このレコード型のポインタ(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;

Object Pascal

と無名メソッドを呼び出すようにします。あとはコールバックとして無名メソッドを受け取るファイルコピー関数を作成します。

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;

Object Pascal

前回同様にフォーム上にコピー元ファイル名とコピー先ファイル名を入力するための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;

Object Pascal

ここではコピー中止のButtonをクリックすると中断するかどうか確認するダイアログを表示するようにしています。

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

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)

第26回エンバカデロ・デベロッパーキャンプ開催決定

第26回エンバカデロ・デベロッパーキャンプは2013年09月13日に開催されます。

エンバカデロ・デベロッパーキャンプ | ホーム
エンバカデロ、第26回デベロッパーキャンプを9月13日東京ビッグサイトにて開催 | Press Releases

2013/08開催のウェブセミナー

• 2013/08/07 13:30-14:30(JST) 8/7 - Webセミナー 「C++の機能を引き出すプログラミングテクニック」
  • Replay (1/2)
  • Replay (2/2)