AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Thema durchsuchen
Ansicht
Themen-Optionen

TPanel in Thread als Progressbar

Ein Thema von DevilsCamp · begonnen am 10. Mär 2006 · letzter Beitrag vom 10. Mär 2006
Antwort Antwort
DevilsCamp
(Gast)

n/a Beiträge
 
#1

TPanel in Thread als Progressbar

  Alt 10. Mär 2006, 14:08
Ich habe eine Form mit zwei Buttons, einer Listbox und einem Panel.

Ich habe folgenden Code:
Delphi-Quellcode:
implementation

uses
  anithread;
const
  maxp = 50000;

procedure TForm1.Button1Click(Sender: TObject);
var
  ani : TAnimationThread;
  r : TRect;
  i : Integer;
begin
  r := panel1.ClientRect;
  InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth);

  posi := 0;
  ani := TAnimationThread.Create(panel1, r, panel1.Color, [clBlack, clBlue], 10, maxp);
  Button1.Enabled := False;
  ListBox1.Items.Clear;

  doit := true;
  i := 0;

  while (doit)and(i<=maxp) do
  begin
    ListBox1.Items.Add(Format('%.6d', [i]));
    inc(i);
    posi := i;

    if (i mod 100)=0 then
      Application.ProcessMessages;
  end;

  Button1.Enabled := True;

  try
    ani.Terminate;
  finally
    ani := nil;
  end;
end;
Der Thread sieht so aus:
Delphi-Quellcode:
unit anithread;

interface

uses
  Classes, Windows, Controls, Graphics, SysUtils;

type
  TAnimationThread = class(TThread)
  private
    { Private declarations }
    FWnd: HWND;
    FPaintRect: TRect;
    FbkColor, FfgColor: TColor;
    FInterval: Integer;
    FMaxPos : Integer;
    FUseColors : Array of TColor;
    image: TBitmap;
    imrect: TRect;
    procedure DrawGradient(ACanvas: TCanvas; Rect: TRect; Horicontal: Boolean;
      Colors: array of TColor);
    procedure PaintText(ACanvas: TCanvas; PaintRect: TRect; fProzent: Integer);
    procedure ShowCaption;
  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}
      maxpos: Integer); overload;

    constructor Create(paintsurface: TWinControl; {Control to paint on }
      paintrect: TRect; {area for animation bar }
      bkColor: TColor; bColors: array of TColor; {colors to use }
      interval: Integer; {wait in msecs between paints}
      maxpos: Integer); overload;

  end;

implementation

uses animprog_main;

constructor TAnimationThread.Create(paintsurface: TWinControl;
  paintrect: TRect; bkColor, barcolor: TColor; interval: Integer; maxpos: Integer);
begin
  inherited Create(True);
  FWnd := paintsurface.Handle;
  FPaintRect := paintrect;
  FbkColor := bkColor;
  FfgColor := barColor;
  FInterval := interval;
  FreeOnterminate := True;
  FMaxPos := maxpos;
  SetLength(FUseColors, 1);
  FUseColors[0] := FfgColor;
  Image := TBitmap.Create;
  Resume;
end; { TAnimationThread.Create }

procedure TAnimationThread.Execute;
var
  Left, Right: Integer;
  increment: Integer;
  state: (incRight, decRight);
  po : Integer;
  proz : Integer;
begin
  try
    with Image do
    begin
      Width := FPaintRect.Right - FPaintRect.Left;
      Height := FPaintRect.Bottom - FPaintRect.Top;
      imrect := Rect(0, 0, Width, Height);
    end; { with }
    Left := 0;
    Right := 0;
    increment := imrect.Right div 50;
    state := Low(State);
    while not Terminated do
    begin
      with Image.Canvas do
      begin
        Brush.Color := FbkColor;

        FillRect(imrect); // original!
        Brush.Color := FfgColor;

        po := Form1.posi;

        if (po>FMaxPos) then
          po := FMaxPos;

        proz := Round(100.0/FMaxPos*po);

        Right := Round((imrect.Right-imrect.Left+1)*1.0/FMaxPos*po);

        DrawGradient(Image.Canvas, Rect(Left, imrect.Top, Right, imrect.Bottom),
          True, FUseColors);

        PaintText(Image.Canvas, imrect, proz);
      end; { with }

      Synchronize(ShowCaption);
      Sleep(FInterval);
    end; { While }
  finally
    Image.Free;
  end;
  InvalidateRect(FWnd, nil, True);
end; { TAnimationThread.Execute }

procedure TAnimationThread.DrawGradient(ACanvas: TCanvas; Rect: TRect;
  Horicontal: Boolean; Colors: array of TColor);
type
  RGBArray = array[0..2] of Byte;
var
  x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
  Faktor: Double;
  A: RGBArray;
  B: array of RGBArray;
  merkw: Integer;
  merks: TPenStyle;
  merkp: TColor;
begin
  mx := High(Colors);
  if mx > 0 then
  begin
    if Horicontal then
      mass := Rect.Right - Rect.Left
    else
      mass := Rect.Bottom - Rect.Top;
    SetLength(b, mx + 1);
    for x := 0 to mx do
    begin
      Colors[x] := ColorToRGB(Colors[x]);
      b[x][0] := GetRValue(Colors[x]);
      b[x][1] := GetGValue(Colors[x]);
      b[x][2] := GetBValue(Colors[x]);
    end;
    merkw := ACanvas.Pen.Width;
    merks := ACanvas.Pen.Style;
    merkp := ACanvas.Pen.Color;
    ACanvas.Pen.Width := 1;
    ACanvas.Pen.Style := psSolid;
    faColorsh := Round(mass / mx);
    for y := 0 to mx - 1 do
    begin
      if y = mx - 1 then
        bis := mass - y * faColorsh - 1
      else
        bis := faColorsh;
      for x := 0 to bis do
      begin
        Stelle := x + y * faColorsh;
        faktor := x / bis;
        for z := 0 to 2 do
          a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
        ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
        if Horicontal then
        begin
          ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
          ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
        end
        else
        begin
          ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
          ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
        end;
      end;
    end;
    b := nil;
    ACanvas.Pen.Width := merkw;
    ACanvas.Pen.Style := merks;
    ACanvas.Pen.Color := merkp;
  end
  else
  begin
    merkp := ACanvas.Brush.Color;
    ACanvas.Brush.Color := Colors[0];
    ACanvas.FillRect(Rect);
    ACanvas.Brush.Color := merkp;
  end;
end;


constructor TAnimationThread.Create(paintsurface: TWinControl;
  paintrect: TRect; bkColor: TColor; bColors: array of TColor; interval,
  maxpos: Integer);
var
  i : Integer;
begin
  inherited Create(true);

  FWnd := paintsurface.Handle;
  FPaintRect := paintrect;
  FbkColor := bkColor;

  if (Length(bColors)=0) then
  begin
    SetLength(FUseColors, 1);

    FUseColors[0] := RGB(255-GetRValue(ColorToRGB(bkColor)),255-GetGValue(ColorToRGB(bkColor)),255-GetBValue(ColorToRGB(bkColor)));
  end
  else
  begin
    SetLength(FUseColors, Length(bColors));

    for i := 0 to High(bColors) do
      FUseColors[i] := bColors[i];
  end;

  FfgColor := FUseColors[0];
  FInterval := interval;
  FreeOnterminate := True;
  FMaxPos := maxpos;
  Image := TBitmap.Create;
  Resume;
end;

procedure TAnimationThread.PaintText(ACanvas: TCanvas; PaintRect: TRect; fProzent: Integer);
var
  Ima2 : TBitmap;
  s : String;
  X : Integer;
  Y : Integer;
  Width : Integer;
  Height : Integer;
begin
  if true then
  begin
    Width := PaintRect.Right-PaintRect.Left+1;
    Height := PaintRect.Bottom-PaintRect.Top+1;
    Ima2 := TBitmap.Create;
    Ima2.Width := Width;
    Ima2.Height := Height;
    
    with Ima2.Canvas do
    begin
      CopyMode := cmBlackness;
      CopyRect(Rect(0, 0, Width, Height), Ima2.Canvas, Rect(0, 0, Width, Height));
      CopyMode := cmSrcCopy;
    end;

    with Ima2.Canvas do
    begin
      Brush.Style := bsClear;
      Font.Color := clWhite;

      s := Format('%d%%', [fProzent]);
      
      with PaintRect do
      begin
        X := (Right - Left + 1 - TextWidth(S)) div 2;
        Y := (Bottom - Top + 1 - TextHeight(S)) div 2;
      end; // with

      TextRect(PaintRect, X, Y, s);
    end; // with Ima2.Canvas

    ACanvas.CopyMode := cmSrcInvert;
    ACanvas.Draw(0, 0, Ima2);

    FreeAndNil(Ima2);
  end;
end;

procedure TAnimationThread.ShowCaption;
var
  DC: HDC;
begin
  DC := GetDC(FWnd);
  if DC <> 0 then
    try
      BitBlt(DC,
        FPaintRect.Left,
        FPaintRect.Top,
        imrect.Right,
        imrect.Bottom,
        Image.Canvas.Handle,
        0, 0,
        SRCCOPY);
    finally
      ReleaseDC(FWnd, DC);
    end;
end;

end.

Nun habe ich das komische Verhalten, dass die Execute-Methode des Threads erst ausgeführt wird, wenn die For-Schleife, die die ListBox füllt schon einen Teil abgearbeitet hat.
Da ich bisher nur einmal mit Threads gearbeitet habe frage ich mich schon, ob dies ein normales Verhalten ist und wenn ja, wie ich den Thread dazu bewegen könnte nach dem "Resume" in den Konstruktoren direkt die Execute-Methode aufzurufen.

(den Quellcode für den Thread habe ich beim SwissDelphiCenter gefunden)
  Mit Zitat antworten Zitat
Benutzerbild von Bernhard Geyer
Bernhard Geyer

Registriert seit: 13. Aug 2002
17.196 Beiträge
 
Delphi 10.4 Sydney
 
#2

Re: TPanel in Thread als Progressbar

  Alt 10. Mär 2006, 14:14
ich hab jetzt nur den Titel gelesen: Schon mal was davon gehört das man auf VCL-Control nur im Hautpthread zugreifen darf? Alles andere gibt komischte Effekte.
Windows Vista - Eine neue Erfahrung in Fehlern.
  Mit Zitat antworten Zitat
Benutzerbild von TeronG
TeronG

Registriert seit: 19. Jul 2004
Ort: München
960 Beiträge
 
Delphi 2007 Professional
 
#3

Re: TPanel in Thread als Progressbar

  Alt 10. Mär 2006, 14:17
Luckie hat da n nettes Tut hilft dir bestimmt weiter.
Hier isses ...
龍 Der Unterschied zwischen Theorie und Praxis ist in der Praxis größer als in der Theorie.
  Mit Zitat antworten Zitat
DevilsCamp
(Gast)

n/a Beiträge
 
#4

Re: TPanel in Thread als Progressbar

  Alt 10. Mär 2006, 14:17
Zitat von Bernhard Geyer:
ich hab jetzt nur den Titel gelesen: Schon mal was davon gehört das man auf VCL-Control nur im Hautpthread zugreifen darf? Alles andere gibt komischte Effekte.
Dann solltest du dir vielleicht erst mal den Code anschauen, bevor du die Tastatur unnötig quälst...
  Mit Zitat antworten Zitat
Benutzerbild von Bernhard Geyer
Bernhard Geyer

Registriert seit: 13. Aug 2002
17.196 Beiträge
 
Delphi 10.4 Sydney
 
#5

Re: TPanel in Thread als Progressbar

  Alt 10. Mär 2006, 14:19
Zitat von DevilsCamp:
Dann solltest du dir vielleicht erst mal den Code anschauen, bevor du die Tastatur unnötig quälst...
Ich habe halt nur den Hauptfehler bei sowas angesprochen. Nicht gleich beleidigt sein.
Und der Code war mir einfach mal zu lang.
Windows Vista - Eine neue Erfahrung in Fehlern.
  Mit Zitat antworten Zitat
Antwort Antwort


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 05:43 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz