type
TAnimationThread = class(TThread)
private
FWnd: HWND;
FPaintRect: TRect;
FInterval: Integer;
FbkColor, FfgColor: TColor;
procedure DrawGradient(ACanvas: TCanvas; Rect: TRect; Horizontal: Boolean; Colors: array of TColor);
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;
var
Animation : TAnimationThread;
Color_nr : integer;
Color_codes : array[0..6] of Tcolor =
($00CCFFCC,$0099CC99,$0099FFCC,$00056557,$00BAFF6F,$0099FFCC,$00CCFFCC);
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;
procedure TAnimationThread.Execute;
var
DC: HDC;
image: TBitmap;
imagerect: TRect;
Alt_col : TColor;
left, right, increment : Integer;
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;
left := 0;
right := 0;
state := Low(State);
increment := imagerect.right div 50;
while not Terminated do
begin
with Image.Canvas do
begin
Brush.Color := FbkColor;
DrawGradient(Image.Canvas, imagerect, True, [FbkColor, FbkColor]);
Case state of
incRight: begin
FfgColor := Color_codes[Color_nr];
Alt_col := Color_codes[Color_nr + 1];
Inc( right, increment );
if right > imagerect.right then
begin
right := imagerect.right;
Inc(state);
end;
end;
incLeft: begin
FfgColor := Color_codes[Color_nr];
Alt_col := Color_codes[Color_nr + 1];
Inc( left, increment );
if left >= right then
begin
left := right;
Inc(state);
Inc(Color_nr);
if Color_nr > 5 then Color_nr := 0;
end;
end;
decLeft: begin
FfgColor := Color_codes[Color_nr];
Alt_col := Color_codes[Color_nr + 1];
Dec( left, increment );
if left <= 0 then
begin
left := 0;
Inc(state);
end;
end;
decRight: begin
FfgColor := Color_codes[Color_nr];
Alt_col := Color_codes[Color_nr + 1];
Dec( right, increment );
if right <= 0 then
begin
right := 0;
state := incRight;
Inc(Color_nr);
if Color_nr > 5 then Color_nr := 0;
end;
end;
end;
Brush.Color := FfgColor;
DrawGradient(Image.Canvas,Rect(Left,imagerect.Top,Right,imagerect.Bottom),True,[FfgColor,Alt_col]);
end;
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;
finally
Image.Free;
end;
InvalidateRect( FWnd, Nil, true );
end;
procedure TAnimationThread.DrawGradient(ACanvas: TCanvas; Rect: TRect;
Horizontal: Boolean; Colors: array of TColor);
type
RGBArray = array[0..2] of Byte;
var
A: RGBArray;
Faktor: Double;
Pen_color: TColor;
Pen_width: Integer;
Pen_style: TPenStyle;
B: array of RGBArray;
x, y, z, mx, pos_nr, size_nr, till_nr, faColorsh: Integer;
begin
mx := High(Colors);
if mx > 0 then
begin
if Horizontal then size_nr := Rect.Right - Rect.Left
else size_nr := 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;
Pen_width := ACanvas.Pen.Width;
Pen_style := ACanvas.Pen.Style;
Pen_color := ACanvas.Pen.Color;
ACanvas.Pen.Width := 1;
ACanvas.Pen.Style := psSolid;
faColorsh := Round(size_nr / mx);
for y := 0 to mx - 1 do
begin
if y = mx - 1 then till_nr := size_nr - y * faColorsh - 1
else till_nr := faColorsh;
for x := 0 to till_nr do
begin
pos_nr := x + y * faColorsh;
faktor := x / till_nr;
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 Horizontal then
begin
ACanvas.MoveTo(Rect.Left + pos_nr, Rect.Top);
ACanvas.LineTo(Rect.Left + pos_nr, Rect.Bottom);
end
else begin
ACanvas.MoveTo(Rect.Left, Rect.Top + pos_nr);
ACanvas.LineTo(Rect.Right, Rect.Top + pos_nr);
end;
end;
end;
b := nil;
ACanvas.Pen.Width := Pen_width;
ACanvas.Pen.Style := Pen_style;
ACanvas.Pen.Color := Pen_color;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
PBS_MARQUEE = $08;
PBM_SETMARQUEE = WM_USER + 10;
Var
L : Integer;
Begin
L := GetWindowLong (ProgressBar1.Handle, GWL_STYLE);
SetWindowLong (ProgressBar1.Handle, GWL_STYLE, L Or PBS_MARQUEE);
SendMessage (ProgressBar1.Handle, PBM_SETMARQUEE, 1, 100);
End;
Use a TTimer with a short interval (like 5ms) and do something like this:
Open in new window