TPageControl.OnChange中的慢事件处理程序会导致奇怪的行为

时间:2011-05-06 20:28:18

标签: delphi delphi-2007 tpagecontrol

当我将慢速代码添加到TPageControl的OnChange事件时,我遇到了问题。

如果代码速度快且不需要花费很多时间,那就很好了 但是,如果代码需要很长时间才能返回+/- 0.5到1秒,则PageControl开始变得怪异。

如果用户更改了某个页面,有时它在第一次点击时不会执行任何操作,并且需要在页面上再次点击才能实际进行更改。

我有点用这样的代码解决这个问题。 (我简化了一下,只是为了表明这个想法)

type TDelayProc = procedure(Sender: TObject) of object;

TForm = class(TForm)
...
private
  FDelayedSender: TObject;
  FDelayedEvent: TDelayProc;
  procedure SetDelayedEvent(Value: TDelayProc);
  property FDelayedSender: TObject read FDelayedSender write FDelayedSender;
  property FDelayedEvent: TDelayProc read FDelayedEvent write SetDelayedEvent;
...

procedure TForm1.SetDelayedEvent(Value: TDelayProc);
begin
  Timer1.Active:= false;
  FDelayedEvent:= Value;
  if Assigned(Value) then Timer1.Active:= true
  else DelayedSender:= nil;    
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Active:= false;
  if Assigned(DelayedEvent) then DelayedEvent(DelayedSender);
end;

procedure TForm1.PageControl1Change(Sender: TObject);
begin
  if PageControl1.ActivePage = TSPage1 then begin
    DelayedSender:= Button1;
    DelayedEvent:= Button1Click;
  end; {if}
end;

你可以看到这是一个可怕的黑客。
我正在调用的代码是在QuickReport中准备报告和MySQL查询等等,所以我对此没有多少控制权。

我认为有一些Win32消息传递让我搞砸了没有从TPageControl.OnChange快速返回,但延迟肯定短于3秒。

我已经尝试了ProcessMessages,但这让事情变得更糟,我不想为此使用单独的线程。

如何解决这个问题,以便我可以像普通<{strong> 一样使用OnChange事件处理程序

3 个答案:

答案 0 :(得分:1)

我唯一的解释是你的长时间处理程序正在抽取消息队列。只要您不抽取队列,只要您愿意处理一个事件就可以。它可能看起来很乱,因为你忽略了队列,但它会正常工作。

答案 1 :(得分:1)

  

我希望有一个BeforeChange事件   这给了我一个新的页面   参数[...]

几乎有。使用OnChanging事件和IndexOfTabAt功能:

// Warning: Don't use, see below!
procedure TForm1.PageControl1Changing(Sender: TObject;
  var AllowChange: Boolean);
var
  pnt: TPoint;
  NewTabIndex: integer;
begin
  if not GetCursorPos(pnt) then Exit;
  pnt := PageControl1.ScreenToClient(pnt);
  NewTabIndex := PageControl1.IndexOfTabAt(pnt.X, pnt.Y);
  if NewTabIndex <> -1 then
    ShowMessageFmt('Next up: tab with index %d.', [NewTabIndex]);
end;

但是:仅当用户点击标签时才有效。如果用户使用键盘导航选项卡控件,则它不起作用。因此,这个答案是无用的(除了用于教育目的)。

答案 2 :(得分:1)

我不清楚你为什么要使用TTimer的东西。如果是我,我想我只是PostMessage来自OnChange事件的自定义消息,因此OnChange处理程序将立即返回。这将允许PageControl消息流正常运行。然后在该自定义消息的消息处理程序中,我将(1)显示/启动在第二个线程上运行的进度条表单,(2)启动花费这么多时间的活动,以及(3)当耗时的活动结束时,关闭进度条。

以下是一些线程进度条的代码,我修改了几年前Peter Below发布的内容。它并不漂亮,但用户并不关心这一点,因为他们关心屏幕上“什么都不会发生”。

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.