Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "WinAPI";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Вниз

Градиентный прогрес в отдельном потоке   Найти похожие ветки 

 
mambo ©   (2009-11-18 12:21) [0]

Нужна помощь знающих потоки. Хочу сделать градиентный прогресс бар написал код. Так как ресурсы машины уходят на его работу переписал с созданием отдельного потока, но прогрес перестал прорисовыватся.
Помогите, где моя ошибка.
Класс прогреса:
unit MyVisualClasess;

interface

uses
 Classes, SysUtils, StdCtrls, ExtCtrls, RzPanel,Forms, Controls,
 Windows;

type
 TMyUnlimProgress = class(TThread)
 private
   FImage : TImage;
   FProgrPan : TPanel;
   FCaption : TCaption;
   FLabel      : TLabel;
   FStop       : boolean; // Признак остановки
   FWay  : Boolean; // направление движения, true - вправо
   FLengthProgr  : Integer; // Счетчик длины градиента
   FSleep : Integer;         // Скорость градиента (задержка)
   FWidthPrgLine :integer;// Довжина градієнту

   procedure CreateComponent (aOwner: TComponent; aWinControl: TWinControl);
 protected
   procedure Execute; override;
   procedure ThreadStop;
 public
   constructor Create(aOwner: TComponent; aWinControl: TWinControl);
 end;

implementation

{ TMyUnlimProgress }

constructor TMyUnlimProgress.Create(aOwner: TComponent; aWinControl: TWinControl);
begin
inherited Create(true);     //Созданный поток создается в приостановленном состоянии
 FreeOnTerminate := True;    //Поток освободит ресурсы при окончании работы
 Self.Priority := tpHighest; //Очень высокий приоритет
 CreateComponent (aOwner,aWinControl);
 Resume;
end;

procedure TMyUnlimProgress.CreateComponent(aOwner: TComponent;
 aWinControl: TWinControl);
begin
 FCaption:= " Мой прогресс... ";
 FProgrPan:= TPanel.Create(AOwner);
 with FProgrPan do begin
   Top:= (aWinControl.Height div 2)- 50;
   Height:= 30;
   Left:= (aWinControl.Width div 2)- 125;
   Width:= 250;
   Parent:= aWinControl;
   Visible:= true;
 end;
 FLabel:= TLabel.Create(aOwner);
 with FLabel do begin
   Align:= alTop;
   Caption:= FCaption;
   Parent:= FProgrPan;
 end;
 FImage:= TImage.Create(AOwner);
 with FImage do begin
   Align:= alClient;
   Parent:= FProgrPan;
 end;
 FLengthProgr:= 0;
 FSleep:= 30;
 FWidthPrgLine:= 100;
 Fstop:= false;
 FWay:= true;
end;

procedure TMyUnlimProgress.Execute;
var
 HandleChange: THandle;  //Handle создаваемого объекта для ожидания события
 i,j,n : Longint;
 v_stmove  : Boolean;
begin
 try
//-- Цикл, пока для потока не будет выдана команда Terminate
   while not Terminated do
   begin
     if FWay then begin
       v_stmove:= false;
      i:= 1; j:=1;
       while (i < FImage.Width+FWidthPrgLine+1) or (not Terminated) do begin
         if FLengthProgr <= FWidthPrgLine then begin
          Inc(FLengthProgr);
         end
          else begin
            v_stmove:= true;
            FLengthProgr:= 0;
          end;
         while (j < FImage.Height - 1) or (not Terminated) do begin
           if v_stmove then
             FImage.Canvas.Pixels[i-FWidthPrgLine-1,j]:= $FFFFFF;
           for n := FWidthPrgLine downto 1 do begin
             FImage.Canvas.Pixels[i-n,j] := RGB((255*n div FWidthPrgLine),(255*n div FWidthPrgLine),255);
           end;
           inc(j);
         end;
         sleep(FSleep);
         inc(i);
       end;
       FWay:= false;
     end;
// move from right to left
      {else begin
        v_stmove:= true;
        FLengthProgr:= 0;
        i:= FImage.Width;
        while i > -(FWidthPrgLine+1) do begin
          if FLengthProgr <= FWidthPrgLine then begin
            Inc(FLengthProgr);
          end
           else begin
             v_stmove:= true;
             FLengthProgr:= 0;
           end;
          for j:=1 to FImage.Height - 1 do begin
            if v_stmove then begin
              FImage.Canvas.Pixels[i+FWidthPrgLine+1,j]:= $FFFFFF;
            end;
            for n := 1 to FWidthPrgLine do begin
              FImage.Canvas.Pixels[i+n,j] := RGB((255*n div FWidthPrgLine),(255*n div FWidthPrgLine),255);//a[n];
            end;
          end;
          sleep(FSleep);
          dec(i);
        end;
        FWay:= true;
      end; }
// end move from right to left
   end;
 finally
 end;
 Synchronize(ThreadStop);
end;

procedure TMyUnlimProgress.ThreadStop;
begin
FImage.Free;
FLabel.Free;
FProgrPan.Free;
end;

end.

Вызов из главной формы:
form1.Tag := Integer(TMyUnlimProgress.Create(self,form1));
остановка потока
 if Assigned(TMyUnlimProgress(form1.Tag)) then
   TMyUnlimProgress(form1.Tag).Terminate;
 form1.Tag := 0;


 
brother ©   (2009-11-18 12:26) [1]

> Так как ресурсы машины уходят на его работу переписал с
> созданием отдельного потока, но прогрес перестал прорисовыватся.

чего куда уходит?) зачем отдельный поток?


 
mambo ©   (2009-11-18 13:06) [2]

Если точнее сказать, то просто выполнение программы уходит в ветку работы прогреса и соответственно пока он не остановится ничего далее работать не будет


 
clickmaker ©   (2009-11-18 13:11) [3]

> Так как ресурсы машины уходят на его работу

когда ресурсы уходят на "шашечки", а не на "ехать" - это не есть гут.
проще всего в рабочий цикл вставить Application.ProcessMessages, и все делать в основном потоке, либо вынести работу в отдельный поток и обновлять прогресс посылкой сообщения


 
mambo ©   (2009-11-18 13:25) [4]


> проще всего в рабочий цикл вставить Application.ProcessMessages,
>  и все делать в основном потоке, либо вынести работу в отдельный
> поток и обновлять прогресс посылкой сообщения


С Application.ProcessMessages не проходит уже пробовал :-(. Поэтому то и пробую сделать в отдельном потоке.


 
brother ©   (2009-11-18 13:26) [5]

а что не работает?


 
mambo ©   (2009-11-18 15:15) [6]

в данном варианте не происходит прорисовка FImage.Canvas. Цикл работает


 
clickmaker ©   (2009-11-18 15:48) [7]

> не происходит прорисовка FImage.Canvas

ну так надо FImage.Update сказать или Refresh


 
Егорка   (2009-11-18 17:39) [8]

Удалено модератором
Примечание: Offtopic



Страницы: 1 вся ветка

Форум: "WinAPI";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.48 MB
Время: 0.062 c
15-1337747844
Медвежонок Пятачок
2012-05-23 08:37
2013.03.22
Многое здесь было, а этого еще не припомню


15-1334228111
Unknown user
2012-04-12 14:55
2013.03.22
Файл-контейнер с сигнатурой pstorage


15-1343421003
Юрий
2012-07-28 00:30
2013.03.22
С днем рождения ! 28 июля 2012 суббота


2-1339576883
Seally
2012-06-13 12:41
2013.03.22
Делфи не признает AdvStringGrid


15-1331466940
Jeer
2012-03-11 15:55
2013.03.22
А вдруг ?





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский