長時間というか，繰り返しの処理の途中経過を表示し，途中でキャンセル
操作できる，使い回し用フォームの例．
　単にループの途中でApplication.ProcessMessagesを呼ぶだけだと予期せぬ
ボタンを押されたりして困るので，別のFormをShowModalして一旦流れを切り，
他のフォーム，自分のフォームの操作を禁止してからコールバックをさせる．
　ループ部分は別フォームに追い出して使い回し．

＊ 謎の全知師さんの発言（at FGALEL）を参考にしていますm(_._)m


--------------------------------------------------------------
unit Progress;

interface

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

const
{ Private Messages }
  wm_PR = $3000;
  PR_START = wm_PR + 1; { start progressing }

type
  // 繰り返し処理のメソッドポインタの型
  TEachProc = procedure( Sender: TObject; Position: integer;
                                          var Abort: boolean) of object;

  TProgressFm = class(TForm)
    ProgressBar1: TProgressBar; // プログレスバー
    Label1: TLabel;
    Label2: TLabel;
    CancelBtn: TButton;         // キャンセルボタン
    procedure CancelBtnClick(Sender: TObject);
  protected
    FMin, FMax, FProgress: integer;
    Abort: boolean;
    FOnProgress: TEachProc;
    procedure StartProgress( var Message: TMessage);  { *1 }
                             message PR_START;
  public
    class function DoProgress( Explanation: string;
                               ACaption: string;
                               Proc: TEachProc;
                               Min,Max: integer): integer;
  end;

implementation

{$R *.DFM}

// ループ回数などを指定してコールバック（イベント）を登録後，実行
class function TProgressFm.DoProgress( Explanation: string;
                                       ACaption: string;
                                       Proc: TEachProc;
                                       Min,Max: integer ): integer;
begin
  with TProgressFm.Create(Application) do begin
    Caption := ACaption;
    Label1.Caption := Explanation;
    FOnProgress := Proc;
    FMin := Min;
    FMax := Max;
    ProgressBar1.Min := Min;
    ProgressBar1.Max := Max;
    ProgressBar1.Position := Min;
    PostMessage( Handle, PR_START, 0, 0);
    ShowModal;            // ここで表示，他の操作は自動的に禁止
    Result := FProgress;  // やったところまでの数字が返る
    Release;
  end;
end;

procedure TProgressFm.StartProgress( var Message: TMessage);
var
  i: integer;
begin
  Update;
  Abort := False;
  for i := FMin to FMax do begin
    FProgress := i;
    ProgressBar1.Position := i;
    Label2.Caption := InttoStr(i-FMin+1)+'/'+InttoStr(FMax-FMin+1);
    Update;
    if Assigned(FOnProgress) then
      FOnProgress(Self, i, Abort); // コールバックの実施
    Application.ProcessMessages;
    if Abort then break;
  end;
  Close;
end;

procedure TProgressFm.CancelBtnClick(Sender: TObject);
begin
  Abort := True;
end;

end.

----使う人（長時間処理をする）のフォーム------------------------------

  TForm1 = class(TForm)
  .......
    procedure EachProc( Sender: TObject; Position: integer;
                                         var Abort: boolean);
  end;

// 長時間処理の開始
procedure TForm1.PrintBtnClick(Sender: TObject);
begin
  TProgressFm.DoProgress( 'ＸＸＸを印刷しています',
                          Caption, EachProc, 0, PageCount-1);
end;

// コールバックされるメソッド
procedure TForm1.EachProc( Sender: TObject;
                           Position: integer;
                           var Abort: boolean);
begin
  // PositionにIndexが入ってくるので，例えばPosition番目の処理をする
  MyPrint( Position );
end;
--------------------------------------------------
*1　OnFormShowとかだとだめなのでメッセージハンドラを作っている．

                                                  ＴＮ(CQJ01721)

Original document by ＴＮ            氏 ID:(CQJ01721)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。