なぜTTimerのものを使用しているのかわかりません。私の場合PostMessage、OnChangeイベントからフォームへのカスタムメッセージを送信するだけなので、OnChangeハンドラーはすぐに返されます。これにより、PageControlメッセージフローが正常に動作できるようになります。次に、そのカスタムメッセージのメッセージハンドラーで、（1）2番目のスレッドで実行されているプログレスバーフォームを表示/開始し、（2）非常に時間がかかるアクティビティを開始し、（3）時間のかかるアクティビティが終了したときに、プログレスバーをシャットダウンします。
スレッド化されたプログレスバーのコードを次に示します。これは、PeterBelowが数年前に投稿したものから変更したものです。きれいではありませんが、ユーザーは画面上で「何も起こらない」ことを気にするほど気にしません。
unit AniMg;
{ Unit for displaying animated progress bar during a lengthy process.
* Painting of progress is done in a secondary thread, so it updates even during processing
which doesn't process Windows messages (and therefore doesn't update visible windows).
* Does NOT call Application.ProcessMessages...so it doesn't alter the order in which the
application processed messages.
USAGE:
//Delays display of the progress form. When this property <> 0, caller must pepper
//his code with .UpdateVisible calls, or the form will never be displayed.
AniMgr.DelayBeforeVisible := 3000;
//If DelayBeforeVisible time has elapsed, displays the progress form & starts thread.
AniMgr.UpdateVisible;
//Displays the progress form & starts painting it in a secondary thread.
//(If DelayBeforeVisible <> 0, sets the form's caption or caption-to-be.)
AniMgr.Push('Some caption');
//To change captions without closing/opening the progress bar form...
AniMgr.Push('Another caption');
//Close the form
AniMgr.PopAll;
NOTES:
* Do NOT call DisableTaskWindows in this unit!! It's tempting to do that when the progress
form is shown, to make it function modally. However, do so at your own risk! Having
DisableTaskWindows in effect resulted in an AV when we were called from certain routines
or component's code.
AUTHOR:
* Mark Wilsdorf, Flagship Technologies, Inc., www.goflagship.com.
* Thanks to Peter Below for his original code for painting the progress bar, and his many
years of providing stellar examples and explanations to the Delphi community.
DEVELOPMENT:
* Originally put FAniform.Show/Update on a TTimer delay, so the progress form wouldn't
display just for a brief instant during quick processes. However, we had to get rid of
Application.ProcessMessages calls (which caused problems in caller), so the TTimer wouldn't
fire. Can't make the 2ndary thread do the Show/Update job either, for the same reason:
Synchronize() won't work because the main thread is occupied in other code, and without
Application.ProcessMessages calls the Synchronize(Show/Update code) doesn't get called
until the lengthy main thread code processing finishes. The only solution appears to be:
have the 2ndary thread be fully responsible for creating and showing/updating the entire
progress window, entirely via Windows API calls.
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, RzLabel, ExtCtrls, RzPanel;
{$I DEFINES.PAS}
type
T_AniForm = class(TForm)
RzPanel2: TRzPanel;
RzLabel1: TRzLabel;
RzPanel1: TRzPanel;
public
r : TRect;
constructor Create(AOwner: TComponent); override;
end;
//Do NOT call DisableTaskWindows in this unit!!
//We may be called from rtnes or components which attempt to update the UI, resulting
//in an AV in certain circumstances. This was the result when used with the popular
//Developer's Express component, ExpressQuantumGrid.
TAniThread = class(TThread)
private
FWnd: HWND;
FPaintRect: TRect;
FbkColor, FfgColor: TColor;
FInterval: integer;
protected
procedure Execute; override;
public
constructor Create(paintsurface : TWinControl; {Control to paint on }
paintrect : TRect; { area for animation bar }
bkColor, barcolor : TColor; { colors to use }
interval : integer); { wait in msecs between paints}
end;
TAniMgr = class(TObject)
private
FStartTime: DWord; //=Cardinal. Same as GetTickCount
FDelayBeforeVisible: cardinal;
FRefCount: integer;
FAniThread : TAniThread;
FAniForm: T_AniForm;
// procedure SetDelayBeforeVisible(Value: cardinal);
procedure StopIt;
public
procedure Push(const NewCaption: string);
procedure UpdateVisible;
//procedure Pop; Don't need a Pop menthod until we Push/Pop captions...
procedure PopAll;
//
//Delay before form shows. Takes effect w/r/t to first Push() call.
property DelayBeforeVisible: cardinal read FDelayBeforeVisible write FDelayBeforeVisible;
end;
function AniMgr: TAniMgr; //function access
implementation
{$R *.dfm}
var
_AniMgr : TAniMgr = nil; //Created privately in Initialization section
//Do NOT DisableTaskWindows in this unit!!
//We're called from some rtnes which attempt to update the UI, resulting in an AV.
//DisabledWindows: pointer = nil;
function AniMgr: TAniMgr;
begin
if not Assigned(_AniMgr) then
_AniMgr := TAniMgr.Create;
Result := _AniMgr;
end;
//---------------------------------------------------------------------------------------------
// TAniMgr
//---------------------------------------------------------------------------------------------
procedure TAniMgr.UpdateVisible;
{ Checks our form's visibility & calls form.Update if appropriate.
* This rtne implements DelayBeforeVisible handling. }
begin
//Thd may be terminating...
if Assigned( FAniThread ) and FAniThread.Terminated then
exit;
if Assigned(FAniForm) and
( (DelayBeforeVisible = 0) or (GetTickCount - FStartTime > DelayBeforeVisible) ) then begin
if not Assigned(FAniThread) then
with FAniForm do begin
Show;
//Form.Update processes our paint msgs to paint the form. Do NOT call
//Application.ProcessMessages here!! It may disrupt caller's intended message flow.
Update;
//Start painting progress bar on the form
FAniThread := TAniThread.Create(RzPanel1, r, FAniForm.color, clActiveCaption, 100);
end
else
FAniForm.Update;
end;
end;
procedure TAniMgr.Push(const NewCaption: string);
{ We don't really Push a stack of captions (though we could)...for now that's not
important; we just manage the form and RefCount. }
begin
//Thd may be terminating...
if Assigned( FAniThread ) and FAniThread.Terminated then
exit;
FRefCount := FRefCount + 1;
if FAniForm = nil then begin
FAniForm := T_AniForm.Create(nil);
//If FAniForm was nil this is the first Push() of a series, so get
//a starting tick count for DelayBeforeShowing management
FStartTime := GetTickCount;
end;
FAniForm.RzLabel1.Caption := NewCaption;
UpdateVisible;
end;
procedure TAniMgr.StopIt;
begin
if Assigned( FAniThread ) then begin
if not FAniThread.Terminated then begin
FAniThread.Terminate;
FAniThread.WaitFor;
end;
end;
FreeAndNil(FAniThread);
FreeAndNil(FAniForm);
end;
//procedure TAniMgr.Pop;
//{ We don't really Pop a stack of captions...for now that's not important; we just
// decrement the RefCount. }
//begin
// if FRefCount > 0 then
// FRefCount := FRefCount - 1;
// if (FRefCount = 0) then
// StopIt;
//end;
procedure TAniMgr.PopAll;
begin
if FRefCount > 0 then try
StopIt;
finally
FRefCount := 0;
end;
end;
//---------------------------------------------------------------------------------------------
// T_AniForm
//---------------------------------------------------------------------------------------------
constructor T_AniForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
r := RzPanel1.ClientRect;
InflateRect(r, - RzPanel1.BevelWidth, - RzPanel1.BevelWidth);
end;
//---------------------------------------------------------------------------------------------
// TAniThread
//---------------------------------------------------------------------------------------------
constructor TAniThread.Create(paintsurface : TWinControl;
paintrect : TRect; bkColor, barcolor : TColor; interval : integer); //BeforePaint: integer);
begin
inherited Create(True); //Suspended
FWnd := paintsurface.Handle;
FPaintRect := paintrect;
FbkColor := bkColor;
FfgColor := barColor;
FInterval := interval;
FreeOnterminate := False; //So we can use WaitFor & know it's dead.
Resume;
end;
procedure TAniThread.Execute;
var
image : TBitmap;
DC : HDC;
left, right : integer;
increment : integer;
imagerect : TRect;
state : (incRight, incLeft, decLeft, decRight);
begin
Image := TBitmap.Create;
try
with Image do begin
Width := FPaintRect.Right - FPaintRect.Left;
Height := FPaintRect.Bottom - FPaintRect.Top;
imagerect := Rect(0, 0, Width, Height);
end; { with }
left := 0;
right := 0;
increment := imagerect.right div 50;
//WAS... increment := imagerect.right div 50;
state := Low(State);
while not Terminated do begin
with Image.Canvas do begin
Brush.Color := FbkColor;
FillRect(imagerect);
case state of
incRight: begin
Inc(right, increment);
if right > imagerect.right then
begin
right := imagerect.right;
Inc(state);
end; { if }
end; { case incRight }
incLeft: begin
Inc(left, increment);
if left >= right then
begin
left := right;
Inc(state);
end; { if }
end; { case incLeft }
decLeft: begin
Dec(left, increment);
if left <= 0 then
begin
left := 0;
Inc(state);
end; { if }
end; { case decLeft }
decRight: begin
Dec(right, increment);
if right <= 0 then
begin
right := 0;
state := incRight;
end; { if }
end; { case decLeft }
end; { case }
Brush.Color := FfgColor;
FillRect(Rect(left, imagerect.top, right, imagerect.bottom));
end; { with }
DC := GetDC(FWnd);
if DC <> 0 then try
BitBlt(DC,
FPaintRect.Left,
FPaintRect.Top,
imagerect.right,
imagerect.bottom,
Image.Canvas.handle,
0, 0,
SRCCOPY);
finally
ReleaseDC(FWnd, DC);
end;
Sleep(FInterval);
end; { while not Terminated}
finally
Image.Free;
end;
InvalidateRect(FWnd, nil, True);
end;
initialization
finalization
if Assigned(_AniMgr) then begin
_AniMgr.PopAll;
_AniMgr.Free;
end;
end.