Отображать движение TProgressBar при помощи фонового потока

Delphi , Компоненты и Классы , TProgressBar

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 
  Question: 

  I am trying query to display records in a dbgrid.however, due to size 
  of tables and joins takes a while for the query to Execute.is 
  there any way to Show a prorgess bar with a timer that increments 
  position but continues to work while the query is being executed.BTW, 
  using access so BDE is not used. 

  Answer: 
   
  A progress bar would not be an ideal choice since you cannot determine up 
  front how long the query will take, so you do not know the range the progress 
  bar has to cover.A simple kind of animation that tells the user basically 
  only that the application is not hung would be more appropriate.One could do 
  such a thing in a secondary thread but it would have to be done using the 
  plain Windows API and * no * Synchronize calls (since the main thread is 
  blocked in the BDE call).Here is an example: unit anithread; 
}

 interface

 uses
   Classes, Windows, Controls, Graphics;

 type
   TAnimationThread = class(TThread)
   private
     { Private declarations }
     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;

 implementation

 constructor TAnimationThread.Create(paintsurface : TWinControl;
   paintrect : TRect; bkColor, barcolor : TColor; interval : integer);
 begin
   inherited Create(True);
   FWnd := paintsurface.Handle;
   FPaintRect := paintrect;
   FbkColor := bkColor;
   FfgColor := barColor;
   FInterval := interval;
   FreeOnterminate := True;
   Resume;
 end; { TAnimationThread.Create }

 procedure TAnimationThread.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;
     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 }
   finally
     Image.Free;
   end;
   InvalidateRect(FWnd, nil, True);
 end; { TAnimationThread.Execute }

 end.

 {Usage: 
 Place a TPanel on a form, size it as appropriate.Create an instance of the 
 TanimationThread call like this: procedure TForm1.Button1Click(Sender : TObject); 
}
 var
   ani : TAnimationThread;
   r : TRect;
   begin
     r := panel1.clientrect;
   InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth);
   ani := TanimationThread.Create(panel1, r, panel1.color, clBlue, 25);
   Button1.Enabled := False;
   Application.ProcessMessages;
   Sleep(30000);  // replace with query.Open or such 
  Button1.Enabled := True;
   ani.Terminate;
   ShowMessage('Done');
 end;

Here is the translation of the text into Russian:

Код, который вы предоставили, - это реализация потока в фоновом режиме, анимирующего прогресс-бар с помощью Windows API. Поток создает объект TBitmap и использует его для рисования прямоугольника на панели, имитируя движение. Позиция прямоугольника обновляется регулярно (определенная свойством FInterval) для создания иллюзии движения.

Вот несколько предложений по улучшению:

1. Вместо использования отдельного потока для анимации можно использовать компонент Timer в вашей основной форме, чтобы достичь того же эффекта без создания нового потока.
2. Код использует Sleep() для приостановки выполнения потока на FInterval миллисекунд. Это может быть проблематично, если система занята или интервал слишком длинный, так как это может привести к тому, что поток будет потреблять больше CPU ресурсов, чем необходимо. Рассмотрите использование WaitForSingleObject() вместо Sleep(), который позволяет ожидать конкретного времени без потребления избыточных CPU ресурсов.
3. Код использует GetDC() и BitBlt() для рисования прямоугольника на панели. Это подход зависит от платформы и может не работать правильно на всех системах. Рассмотрите использование методов TCanvas (например, Brush.Color и FillRect()) для рисования прямоугольника напрямую на панели.
4. Код не обрабатывает ошибки или исключения должным образом. Рассмотрите добавление блоков try-except для ловли и обработки любых ошибок, которые могут возникнуть при выполнении.

Вот обновленная версия кода, которая включает в себя эти предложения:

unit AnimationThread;
...

и пример использования обновленного кода:

procedure TForm1.Button1Click(Sender: TObject);
var
  ani: TAnimationThread;
  r: TRect;
begin
  r := panel1.ClientRect;
  InflateRect(r, -panel1.BevelWidth, -panel1.BevelWidth);
  ani := TAnimationThread.Create(panel1, r, panel1.Color, clBlue, 25);
  Button1.Enabled := False;
  Application.ProcessMessages;
  Sleep(30000); // замените на query.Open или что-то подобное
  Button1.Enabled := True;
  ani.Terminate;
  ShowMessage('Done');
end;

Отображать движение TProgressBar при помощи фонового потока для отображения прогресса выполнения запроса в базе данных.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: TProgressBar ::