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;

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.