Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2007年04月03日] [更新 2015年08月02日]　Delphi サンプルプログラム集
840_処理のキャンセル・画面更新の停止・キーやマウスの操作禁止
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
840_CancellLockDisable.zip　[6,214 KB]　2015年08月02日版 (EXE 同梱)






処理のキャンセル，画面更新の停止，キーやマウスの操作禁止


主に，長い処理，時間のかかる処理などの途中で処理を中断したい場合などのサンプルです．
また，画面の更新の停止と，処理中にキーやマウスの処理を無効にするためのサンプルコードも掲載しています．それぞれ目的に応じて利用して下さい．また，これらの動作を組合わせたり，その一部を使用することも考えられます．

[004_タイマー] に簡単な使用例がありますが，時間かかる処理はスレッドを使用するのが基本と思われます．第 16 回エンバカデロ・デベロッパーキャンプの資料の「正しい GUI の作り方 - 重い処理で GUI が固まるのを防ぐ」に説明があります．
もちろんスレッド処理が必ずしも常に適切というわけではありません．
関数によっては，その関数のコールバック関数内で，終了等の処理ができる場合があります．

Delphi 2010 以降には，同期処理用の TMonitor (System ユニット) というのもあります．デベロッパーキャンプの資料の，Delphi 7 ユーザと初心者のための Delphi 2010 入門」に説明があります．

本ページのサンプルでは使用していませんが，時間がかかる処理の間，マウスカーソルの形を砂時計等にすることが一般的に行われているようです．また，プログレスバー等で進行状況 (進捗状況) を表示することも行われています．

ちなみに「画面の表示停止」ではありません．表示を停止してしまうと何も表示されません．


本ページの [処理のキャンセル] とは少し意味合いが違いますが，フォームを閉じるという「処理」のキャンセル等については，以下を参考にしてください．





01_処理をキャンセルする方法 ( うまくいかないコード )


処理中に，処理を中断したい時，[キャンセル] とか [中止] のボタンを配置し，そのクリックイベントに中断の処理を書くわけですが，実際には，ある変数を用意して，処理中にその変数の値を判定して処理を継続するか，中止するかを決定する方法が使われています．このような目的に使用する変数のことをフラグ (旗) と言っています (印刷やデータベースでは，Abort というメソッドも使われます)．

下のサンプルプログラムは，長い処理の代わりにループを回すことで代用していますが，このコードは実行すると，[中止] ボタンを操作できないどころか，終了もできなくなってしまいます．


図1
設計時画面
図2
実行
  • 終了できない
  • デバッグ時に終了するには [実行] [プログラムの終了] で
  • EXE での実行時は [Ctrl] + [Alt] + [Delete]

リスト1
処理のキャンセルができないコード 
unit Cancell01Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueにする
//  ただしこのサンプルプログラムでは意味なし
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag := True;
end;

//=============================================================================
//  長い処理の間にその操作開始に使用したボタンだけを操作できないようにする
//  Application.ProcessMessages;を入れないとメッセージ処理が行われない例
//
//  途中で終了するにはデバッグ中は[実行][プログラムの終了]
//  EXEからの実行で止めるにはタスクマネージャーを使用
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';
  Edit1.Update;
  Panel1.Update;

  StopFlag := False;

  StartTime := TimeGetTime;
  //時間のかかる処理の代わりとしてのループ
  while True do begin
    if StopFlag then break;

    TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
    Panel1.Caption := TimeStr;
  end;

  StopFlag := False;

  Button1.Enabled := True;
  Button2.Enabled := False;
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//  ただしこのサンプルプログラムでは意味なし
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  StopFlag := True;
  MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

end.



02_処理をキャンセルする方法 ( Application.ProcessMessages )


上のサンプルでは，マウスボタンのメッセージさえも処理できません．そのためプログラム処理中に何も操作できなくなっています．

ボタンクリックやマウス，キーの操作をすると，それらのメッセージはそのスレッドのメッセージキューという場所にポスト (格納) されます．Application.ProcessMessage メソッドを実行すると，メッセージキューにポストされたメッセージをポストされた順番に処理します．下に示すサンプルコードでは，ループ処理内に Application.ProcessMessage を挿入しています．したがって，ボタンクリックのメッセージも処理してくれます．



[備考]
前項のサンプルにはメッセージキューの処理がありません．ループ処理の間のキー押下やマウス操作のメッセージは，メッセージキューにポストされて溜まっていきます．メッセージキューに溜まったそれらのメッセージは，Button1 クリックのイベントが終了すると，メッセージキューにポストされた順番に処理されます．
したがって，前項のサンプルコードでは，ループ処理中にフォームの [X] ボタンをクリックすると，Button1 のイベントの処理が終了すとフォームが自動的に閉じることになります．本項のサンプルでは，ループ処理中でもフォームを閉じることができます．



図3
設計時画面
図4
処理開始
  • [中止] ボタンのクリックは可能
図5
処理中
  • 処理中に Edit への入力も可能
図6
[中止] ボタンクリック

リスト2
Application.ProcessMessages を使って処理の中断を可能にする 
unit Cancell02Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueする
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag := True;
end;

//=============================================================================
//  長い処理の間にその操作開始に使用したボタンだけを操作できないようにする
//  Application.ProcessMessages;を挿入してメッセージ処理を行うようにした例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';

  StopFlag := False;

  StartTime := TimeGetTime;
  //時間のかかる処理の代わりとしてのループ
  //[中止]ボタンか300秒経過したら終了
  while not StopFlag do begin
    if (timeGetTime - StartTime) > 300000 then break;

    TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
    Panel1.Caption := TimeStr;

    Application.ProcessMessages;
    Sleep(1);
  end;
  StopFlag := True;

  Button1.Enabled := True;
  Button2.Enabled := False;
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
    StopFlag := True;
    MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

end.



03_ [ キャンセル ] ボタン以外のキーやマウスの操作を禁止


上のコードでは，処理中に Edit に対しての入力が可能となっていましたが，次のコードは，処理中に [中止] ボタン以外は使用不可にした例です．
TApplicationEvents コンポーネントの OnMessage イベントを使用してその処理を行っています．


図7
設計時画面
  • TApplicationEvents を配置
図8
実行中
  • [中止] ボタン以外は操作不可>

リスト3
[ キャンセル ] ボタン以外のキーやマウスの操作を禁止		 
unit Cancell03Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, AppEvnts;

type
  TForm1 = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure Button2Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  TApplicationEventsのOnMessageでメッセージ処理を行っている関係上，実行中止の
//  フラグであるStopFlagの初期化が必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  StopFlag := True;
end;

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueする
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag := True;
end;

//=============================================================================
//  [開始]ボタン
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';

  StopFlag := False;

  StartTime := TimeGetTime;
  //時間のかかる処理の代わりとしてのループ
  //[中止]ボタンか300秒経過したら終了
  while not StopFlag do begin
    if (timeGetTime - StartTime) > 300000 then break;

    TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
    Panel1.Caption := TimeStr;

    Application.ProcessMessages;
    Sleep(1);
  end;
  StopFlag := True;

  Button1.Enabled := True;
  Button2.Enabled := False;
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  StopFlag := True;
  MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

//=============================================================================
//  StopFlagがFalseの間は[中止]ボタン以外のマウス，キー操作を不可にする
//=============================================================================
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if Msg.hwnd = Button2.Handle then exit;

  if not StopFlag then begin
    if (Msg.message = WM_KEYDOWN)     or
       (Msg.message = WM_LBUTTONDOWN) or
       (Msg.message = WM_RBUTTONDOWN) then begin
      Handled := True;
    end;
  end;
end;

end.



04_画面の更新を停止


次のコードは，LockWindowUpdate を実行して，画面の更新を停止します．グラフィクス等の描画処理示には時間がかかりますから，画面の表示を停止すれば，実行速度が早くなる可能性があります．
この LockWindowUpdate 関数は，処理中にフォームの移動，リサイズを行うと，画面更新の機能が無効となってしまいます．
なお，LockWindowUpdate(0) は，画面の再描画の際，画面全体をリフレッシュするため，一瞬ですが，画面がちらつきます．

画面の更新停止は，上記の様に，描画の際のチラツキ防止や実行速度の改善に使用されますが，コントロールによっては，BeginUpdate，EndUpdate というメソッドがあります．


[備考]
LockWindowUpdate は主にドラッグ操作 (アイテムのドラッグアンドドロップやウィンドウ) の際の描画更新を停止するための関数です．一般的なウィンドウコントロールでは WM_SETREDRAW メッセージを使用することができます．

描画の更新を抑制する時は，WM_SETREDRAW メッセージの WPARAM の値を 0 (False と等価) にします．WM_SETREDRAW メッセージの WPARAM の値を 1 にして描画を再開したら，再描画対象のコントロールに応じて InvalidateRect やコントロールの Refresh メソッド等を実行します．
WM_SETREDRAW メッセージによる描画の抑制は全ての TWinControl で有効です．



図9
設計時画面
図10
[中止] ボタンクリック
図11
処理中断または終了
  • 中止または終了すると，実際の描画が表示される
  • 途中で Edit に入力した文字も見える (処理中の入力時には見えない)
  • フォームの移動操作等を行うと画面表示の停止機能は無効となる

リスト4
画面の更新を停止 
unit LockDisable01Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    Image1: TImage;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueする
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag:=True;
end;

//=============================================================================
//  [開始]ボタン
//  実行中にフォームを移動すると表示の更新は有効になってしまう
//  (フォームを移動すると再描画が必要なため)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';

  Image1.Picture.Assign(nil);
  Panel1.Update;
  Image1.Update;

  StopFlag  := False;
  StartTime := TimeGetTime;

  LockWindowUpdate(Form1.Handle);

  //Image1に図形(ここでは線)を描画
  with Image1.Canvas do begin
    Pen.Width := 20;
    MoveTo(0, 0);
    LineTo(50, 50);
  end;

  StopFlag:=False;

  //時間のかかる処理の代わりとしてのループ
  //[中止]ボタンか300秒経過したら終了
  while not StopFlag do begin
    if (timeGetTime - StartTime) > 300000 then break;

    Application.ProcessMessages;
    Sleep(1);
  end;
  TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
  Panel1.Caption := TimeStr;

  StopFlag := True;

  Button1.Enabled := True;
  Button2.Enabled := False;

  LockWindowUpdate(0);
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  StopFlag := True;
  MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

end.



05_画面の更新を停止 ( キーバッファーのクリア )


処理途中に TEdit に入力した (タイプした) 文字が，終了後に表示されないようにする．つまり，メインの処理中のキー入力を無効にする例です．処理中にキーバッファーをクリアします．


図12
設計時画面
図13
終了時
  • 途中で TEdit に入力した値も表示されない

リスト5
画面の更新を停止 (キーバッファーのクリア機能付き) 
unit LockDisable02Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    Image1: TImage;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueする
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag := True;
end;

//=============================================================================
//  [開始]ボタン
//  実行中にフォームを移動すると表示の更新は有効になってしまう
//  (フォームを移動すると再描画が必要なため)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
  Msg       : tagMsg;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';

  Image1.Picture.Assign(nil);
  Panel1.Update;
  Image1.Update;

  StopFlag  := False;
  StartTime := TimeGetTime;

  LockWindowUpdate(Form1.Handle);

  //Image1に図形(ここでは線)を描画
  with Image1.Canvas do begin
    Pen.Width:=20;
    MoveTo(0, 0);
    LineTo(50, 50);
  end;

  StopFlag:=False;

  //時間のかかる処理の代わりとしてのループ
  //[中止]ボタンか300秒経過したら終了
  while not StopFlag do begin
    if (timeGetTime - StartTime) > 300000 then break;

    //キーバッファのクリア
    while PeekMessage(Msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) do;

    Application.ProcessMessages;
    Sleep(1);
  end;
  TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
  Panel1.Caption := TimeStr;

  StopFlag := True;

  Button1.Enabled := True;
  Button2.Enabled := False;

  LockWindowUpdate(0);
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  StopFlag := True;
  MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

end.



06_システム全体でマウスとキー操作を禁止


処理中にマウスも，キー操作も禁止しても構わないのであれば，BlockInput 関数を利用することもできます．ただし，これはシステム全体に機能するため，処理中はなにも操作できなくなります．
次のサンプルでは，15 秒間だけこの機能を使用しています．


図14
設計時画面
図15
[開始]ボタンクリック
  • 15 秒間はシステム全体のキーマウス操作不可
  • [Ctrl] + [Alt] + [Delete] は使用可能

リスト6
時間のかかる処理の間，システム全体でマウスとキー操作を禁止 
unit LockDisable03Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  システム全体でキーボードとマウスを15秒間使用不可にする
//
//  Windows APIのBlockInput関数を使用(Delphi 2010)
//  BlockInputは引数にTrueを与えるとロックを，Falseを与えると解除となる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Edit1.Text     := '';
  Panel1.Caption := '';

  StartTime := TimeGetTime;
  try
    BlockInput(True);

    //時間のかかる処理の代わりとしてのループ
    while True do begin
      if (timeGetTime - StartTime) > 15000 then break;

      TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
      Panel1.Caption := TimeStr;

      Application.ProcessMessages;
      Sleep(1);
    end;
  finally
    BlockInput(False);
  end;
end;

end.


Delphi 2010より前のバージョンには，BlockInput 関数はありません．以下のように利用者が定義して使用することになります．


リスト7
システム全体でマウスとキー操作を禁止 (Delphi 2010 より前のバージョン用のコード) 

unit LockDisable03Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  TBlockInputProc = function(Block: BOOL): BOOL; stdcall;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  システム全体でキーボードとマウスを15秒間使用不可にする
//
//  Windows APIのBlockInput関数を使用(Delphi 2010)
//  BlockInputは引数にTrueを与えるとロックを，Falseを与えると解除となる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  bBlockInput : TBlockInputProc;
  StartTime   : DWORD;
  TimeStr     : String;
  ShHandle    : THandle;
begin
  Edit1.Text     := '';
  Panel1.Caption := '';

  StartTime := TimeGetTime;

  ShHandle    := LoadLibrary('USER32.DLL');
  bBlockInput := GetProcAddress(ShHandle, 'BlockInput');
  bBlockInput(True);
  try
    //時間のかかる処理の代わりとしてのループ
    while True do begin
      if (timeGetTime - StartTime) > 15000 then break;

      TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
      Panel1.Caption := TimeStr;

      Application.ProcessMessages;
      Sleep(1);
    end;
  finally
    bBlockInput(False);
    FreeLibrary(ShHandle);
  end;
end;

end.



07_アプリのウィンドウ操作を禁止


アプリケーション全体でキーやマウスの操作を禁止してしまう例です．
DisableTaskWindows を使用しています．処理中は，ユーザに一切の操作をさせたくない場合は便利かも知れません．
このコードを実行すると，実行中は，フォームの移動も不可能になります．


図16
設計時画面
図17
実行中
  • フォームの移動も不可

リスト8
時間のかかる処理の間，アプリケーションのウィンドウ操作を禁止 
unit LockDisable04Unit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  アプリのウィンドウ操作を15秒間禁止する
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
  pTaskWnd  : Pointer;
begin
  Edit1.Text     := '';
  Panel1.Caption := '';

  //操作不可にする
  pTaskWnd  := DisableTaskWindows(0);
  StartTime := TimeGetTime;
  try
    while True do begin
      if (TimeGetTime - Starttime) > 15000 then break;

      TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
      Panel1.Caption := TimeStr;

      Application.ProcessMessages;
      Sleep(10);
    end;
  finally
    //終了後は元に戻す
    EnableTaskWindows(pTaskWnd);
  end;
end;

end.



08_ Application.ProcessMessage の代替えルーチン


Application.ProcessMessage は，「その時対処しなければならない，メッセージキューにポストされたメッセージをとりあえず処理」し，再描画が必要なら実行します．これは，他のコントロールを操作したり，フォームの閉じるボタンの操作，また，リサイズ，ボタンを押す，あるいはマウスやキーの操作等の処理も全部受け取ることになります．このため予期しない動作が行われてしまうことがあります．これを避けるには， を使用した代替えルーチンを用いると有効な場合があります．ただし，このサンプルコードはこの現象を確認するためのいい例とは言えません．

再描画には，Update もありますが，これは保留中の PAINT メッセージの処理を行います．
また Repaint は強制的に，コントロール (コンポーネント) 全領域を描き直すメソッドです．


図18
設計時画面
図19
実行中
  • [中止] ボタンはメッセージで検出
図20
実行中
  • [中止] ボタンクリック

リスト9
Application.ProcessMessage の代替えルーチン 
unit RemoveMessageUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Panel1: TPanel;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
    StopFlag : Boolean;
    procedure ProcessPaintMessages;    
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MMSystem;

{$R *.dfm}

//=============================================================================
//  処理の途中でもフォームを閉じることができるようにStopFlagをTrueしても
//  ProcessPaintMessageでメッセージキューを削除しているので無効
//=============================================================================
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  StopFlag:=True;
end;

//=============================================================================
//  Application.ProcessMessagesの代替えルーチンを使用した例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  StartTime : DWORD;
  TimeStr   : String;
begin
  Button1.Enabled := False;
  Button2.Enabled := True;

  Edit1.Text     := '';
  Panel1.Caption := '';
  Panel1.Update;
  Edit1.Update;

  StopFlag := False;

  StartTime := TimeGetTime;
  //時間のかかる処理の代わりとしてのループ
  //[中止]ボタンか300秒経過したら終了
  while not StopFlag do begin
    if (timeGetTime - StartTime) > 300000 then break;

    TimeStr := FormatFloat('#,##0.0 秒', (TimeGetTime - StartTime) / 1000);
    Panel1.Caption := TimeStr;

    ProcessPaintMessages;
    Sleep(1);
  end;
  StopFlag := True;

  Button1.Enabled := True;
  Button2.Enabled := False;
end;

//=============================================================================
//  [中止]ボタン
//  StopFlag変数の値を変更する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  StopFlag := True;
  MessageDlg('中止しました　', mtInformation, [mbOK], 0);
end;

//=============================================================================
//  Application.processMessageの代替えルーチン
//  必要なメッセージのみを処理
//=============================================================================
procedure TForm1.ProcessPaintMessages;
var
  Msg1: TMsg;
  Msg2: TMsg;
begin
  //Button2のメッセージキューにWM_LBUTTONDOWNメッセージがあれば処理
  //Button2は[中止]操作なので，SendMessageで有効にしておく
  if PeekMessage(Msg1,
                 Button2.Handle,
                 WM_LBUTTONDOWN, WM_LBUTTONDOWN,
                 PM_REMOVE) then begin

    while PeekMessage(Msg1, Button2.Handle, WM_LBUTTONUP, WM_LBUTTONUP,PM_REMOVE) do;

    SendMessage(Button2.Handle, WM_LBUTTONDOWN, Msg1.wParam, Msg1.lParam);
    SendMessage(Button2.Handle, WM_LBUTTONUP,   Msg1.wParam, Msg1.lParam);
  end;

  //whileでバッファクリア
  while PeekMessage(Msg2, 0, WM_NCPAINT,    WM_NCPAINT,    PM_REMOVE) or
         PeekMessage(Msg2, 0, WM_ERASEBKGND, WM_ERASEBKGND, PM_REMOVE) or
         PeekMessage(Msg2, 0, WM_PAINT,      WM_PAINT,      PM_REMOVE) do begin
    TranslateMessage(Msg2);
    DispatchMessage (Msg2);
  end;
end;

end.


上のコードは特定のメッセージだけを処理する例ですが，Application.ProcessMessage でポストされたメッセージの中で特定のメッセージだけを無効にするのであれば，該当するメッセージだけを処理しないようるする考え方もあります．





09_ 時間のかかる処理の間，アプリケーションを非表示にする


もし，[キャンセル] や 処理の [中止] 等の機能が必要なければ，時間のかかる処理の間，アプリケーションを非表示にしてしまう方法も考えられます．
そうすれば，処理の間，アプリケーションを操作することはできません．

このサンプルでは，アプリケーションウィンドウを非表示にすると同時に，アプリケーションのアイコンもタスクバーに表示しないようにします．そのために，MainFormOnTaskbar の値を False にして，タスクバーには，アプリケーションウィンドウのアイコンを表示するようにしておきます．
そして，そのアプリケーションウインドウを実行時に非表示にします．アプリケーションウインドウのハンドルは Application.Handle です．
MainFormOnTaskbar の値が デフォルトの True の時は，タスクバーには，メインフォーム (メインフォームのウィンドウ) のアイコンが表示されます．


Delphi 2007 よりも前のバージョンで同じような動作を実現するには，[Delphiで、Windows Vista Readyアプリケーションを作る] にある以下の記事を参考にしてください．



図21
サンプルの EXE を起動

図22
時間のかかる処理を実行
  • アプリを非表示
  • タスクバーにも非表示
  • タスクバーに表示されていると，操作できてしまう

リスト10
サンプルのプロジェクトのソースコード
Application.MainFormOnTaskbar の値を False にしておく 
program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := False; //Falseにする
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


リスト11
時間のかかる処理を実行中は，アプリケーションを非表示にする		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.Title := 'TEST';
end;

//=============================================================================
//  アプリケーションを最小化して，タスクバーにも非表示にする
//  プロジェクトソースのMainFormOnTaskbarをFalseにしておく
//  Application.MainFormOnTaskbar := False;
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  //アプリケーションを最小化する
  Application.Minimize;
  ShowWindow(Application.Handle, SW_HIDE);

  //時間のかかる処理の代わり
  Sleep(5000);

  //アプリケーションの状態を元に戻す
  Application.Restore;
  SetForegroundWindow(Handle);
end;

end.



10_ 「応答なし」を体験する


時間のかかる処理が適切に行われないと，「応答なし」の状態になって，アプリケーションの操作が不可能となり，強制終了が必要となることがあります．
この状態を簡単に確認するサンプルです．単に Sleep 関数を実行するだけです．
  • (1) EXE を起動して，Button1 をクリック
  • (2) 別のアプリケーションにフォーカスを移動
  • (3) 数秒後に本アプリをアクティブにする
で確認できます．「応答なし」になるまでの時間は，Windows のバージョンによって異なります．
このコードの場合，指定時間経過すれば「応答なし」の表示が消えて，フォームの操作は可能になりますが，これは Sleep 関数の特性によるものです．時間のかかる処理はアプリケーションによって異なります．したがって，必ずしも復帰するとは限りません．



図23
時間のかかる処理が適切でないと「応答なし」になる

リスト12
「応答なし」を体験する		 
//=============================================================================
//  応答なしを体験する
//  (1) Button1をクリック
//  (2) 別のアプリをアクティブにする
//  (3) 何秒か経過したら，このフォームをクリックする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  Sleep(30000);
end;



11_データをリスト表示する際の描画更新の抑制 - 処理の高速化


本ページの記事の趣旨とは少し違いますが，TListBox 等，データをリスト表示するコントロール (コンポーネント) があります．これらのコントロールのリストの要素にデータを追加する際，描画の更新を抑制するための，以下のようなメソッドがあります．データベース関係では TDataSet に専用のメソッドがあります．
画面の更新の抑制，停止ではなく，コントロールの描画更新の抑制，停止ということになります．

一般に画面への描画には時間がかかります．描画の更新を抑制すれば，描画の際のチラつきの防止，処理の高速化が期待できます． 



   TStrings.BeginUpdate
   TStrings.EndUpdate

   TListItems.BeginUpdate
   TListItems.EndUpdate

   TDataSet.DisableControls
   TDataSet.EnableControls


具体的なコントロールの例として，次のようなものがあります． 


  TMemo.Lines.BeginUpdate;
  //Linesプロパティに対する操作
  TMemo.Lines.EndUpdate;

  TListView.Items.BeginUpdate;
  //Itemsに対する操作
  TListView.Items.EndUpdate;

  TListBox.Items.BeginUpdate;
  //Itemsに対する操作
  TListBox.Items.EndUpdate;

  TTreeView.Items.BeginUpdate;
  //Itemsに対する操作
  TTreeView.Items.EndUpdate;

  //データベース関係コントロールの描画更新の抑制s

  TTable.DisableControls;
  //TTableに対する操作
  TTable.EnableControls;

  TQuery.DisableControls;
  //TQueryに対する操作
  TQuery.EnableControls;

  TADOQuery.DisableControls;
  //TADOQueryに対する操作
  TADOQuery.EnableControls;


下図は，実際に TListView で，この描画の抑制の効果を確認した結果です．図の下のコードがテストに使用したコードです．



図24
TListView の描画更新を抑制した場合の効果
  • Button1 は描画の更新を抑制しない場合
  • Button2 は描画の更新を抑制する場合

リスト13
BeginUpdate, EndUpdate の効果を確認するテスト
TListView コントロールの場合		 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Grids, StdCtrls, ComCtrls, CommCtrl;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    ListView1: TListView;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    FItemCount : Integer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  MMSystem;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FItemCount := 10000;
end;

//=============================================================================
//  BeginUpdate,EndUpdateなし
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  i         : Integer;
  LCol      : TListColumn;
  LItem     : TListItem;
  StartTime : DWORD;
  EndTime   : DWORD;
begin
  Label1.Caption := '';
  ListView1.Items.Clear;
  ListView1.Columns.Clear;
  ListView1.ViewStyle := vsReport;
  LCol :=  ListView1.Columns.Add;
  LCol.Width := 200;

  StartTime := TimeGetTime;

  for i := 0 to FItemCount - 1 do begin
    LItem := ListView1.Items.Add;
    LItem.Caption := Format('    %.10d',[i + 1]);
  end;

  EndTime       := timeGetTime;
  Label1.Caption:= IntToStr(EndTime - StartTime) + ' ms';
end;

//=============================================================================
//  BeginUpdate,EndUpdateあり
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  i         : Integer;
  LCol      : TListColumn;
  LItem     : TListItem;
  StartTime : DWORD;
  EndTime   : DWORD;
begin
  Label2.Caption := '';
  ListView1.Items.Clear;
  ListView1.Columns.Clear;
  ListView1.ViewStyle := vsReport;
  LCol :=  ListView1.Columns.Add;
  LCol.Width := 200;

  StartTime := TimeGetTime;

  ListView1.Items.BeginUpdate;
  for i := 0 to FItemCount - 1 do begin
    LItem := ListView1.Items.Add;
    LItem.Caption := Format('    %.10d',[i + 1]);
  end;
  ListView1.Items.EndUpdate;

  EndTime       := timeGetTime;
  Label2.Caption:= IntToStr(EndTime - StartTime) + ' ms';
end;

end.