Блог

Когда я добавляю медленный код к OnChange событию TPageControl, я сталкиваюсь с проблемами.

Если код выполняется быстро и не занимает много времени, все в порядке.
Однако, если коду требуется много времени для возврата от /- 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 , но это только ухудшило ситуацию, и я не хочу использовать для этого отдельный поток.

Как мне это исправить, чтобы я мог использовать OnChange обработчик событий как обычный

Мне неясно, почему вы используете материал TTimer. Если бы это был я, я думаю, я бы просто PostMessage отправил пользовательское сообщение в свою форму из события onChange, чтобы обработчик onChange немедленно вернулся. Это позволило бы потоку сообщений PageControl вести себя нормально. Затем в обработчике сообщений для этого пользовательского сообщения я бы (1) показал / запустил форму индикатора выполнения, запущенную во втором потоке, (2) запустил действие, которое занимает так много времени, и (3) когда трудоемкое действие завершится, выключил индикатор выполнения.

Вот некоторый код для поточного индикатора выполнения, который я модифицировал из того, что Питер опубликовал несколько лет назад. Это некрасиво, но пользователей это волнует не так сильно, как то, что на экране «ничего не происходит».

 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 amp; starts thread.
      AniMgr.UpdateVisible;
          //Displays the progress form amp; 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 amp; 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 amp; 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.
  

Единственное объяснение, которое у меня есть, это то, что ваш долго работающий обработчик загружает очередь сообщений. Пока вы не загружаете очередь, вы можете обрабатывать событие столько, сколько захотите. Это может выглядеть неаккуратно, поскольку вы пренебрегаете очередью, но это будет работать нормально.

Я бы хотел, чтобы было 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;
  

Но: Это работает, только если пользователь нажимает на вкладку. Это не работает, если пользователь перемещается по элементу управления tab с помощью клавиатуры. Следовательно, этот ответ бесполезен (кроме как в образовательных целях).