Градиентная заливка.

15:28
unit Unit1;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
 
type
COLOR16 = Word;
 
PTriVertex = ^TTriVertex;
_TRIVERTEX = packed record
x: Longint;
y: Longint;
Red: COLOR16;
Green: COLOR16;
Blue: COLOR16;
Alpha: COLOR16;
end;
TTriVertex = _TRIVERTEX;
TRIVERTEX = _TRIVERTEX;
 
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
i: integer;
buf: TBitmap;
procedure Drawbar(prc: integer);
public
{ Public declarations }
end;
 
var
Form1: TForm1;
function GradientFill(DC: HDC; var p2: TTriVertex;
p3: ULONG; p4: Pointer; p5, p6: ULONG): BOOL; stdcall;
external 'msimg32.dll' name 'GradientFill';
 
implementation
 
{$R *.dfm}
 
procedure GradientRect(DC: HDC; const Rect: TRect;
StartColor, EndColor: TColor; HorizDir: Boolean);
var
vert: array[0..1] of TRIVERTEX;
gRect: GRADIENT_RECT;
const
Direction: array[Boolean] of DWORD =
(GRADIENT_FILL_RECT_V, GRADIENT_FILL_RECT_H);
begin
StartColor := ColorToRGB(StartColor);
EndColor := ColorToRGB(EndColor);
 
vert[0].x := Rect.Left;
vert[0].y := Rect.Top;
vert[0].Red := GetRValue(StartColor) shl 8;
vert[0].Green := GetGValue(StartColor) shl 8;
vert[0].Blue := GetBValue(StartColor) shl 8;
vert[0].Alpha := $0000;
 
vert[1].x := Rect.Right;
vert[1].y := Rect.Bottom;
vert[1].Red := GetRValue(EndColor) shl 8;
vert[1].Green := GetGValue(EndColor) shl 8;
vert[1].Blue := GetBValue(EndColor) shl 8;
vert[1].Alpha := $0000;
 
gRect.UpperLeft := 0;
gRect.LowerRight := 1;
GradientFill(DC, vert[0], 2, @gRect, 1, Direction[HorizDir]);
end;
 
procedure TForm1.Drawbar(prc: integer);
var
r: trect;
begin
r := rect(0, 0, 300, 40);
GradientRect(buf.canvas.Handle, r, $00FFAAAA, clwhite, false);
frame3d(buf.canvas, r, clBtnShadow, clBtnHighlight, 1);
r.Right := r.Left + prc * 3;
GradientRect(buf.canvas.Handle, r, clwhite, clnavy, false);
canvas.CopyRect(rect(10, 10, 310, 50), buf.canvas, rect(0, 0, 300, 40));
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Drawbar(i);
inc(i);
if i > 100 then i := 0;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
buf := TBitmap.Create;
with buf do begin
Canvas.Brush.Color := clBtnFace;
Width := 300;
Height := 20;
end;
Timer1.Interval := 40;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
buf.Free;
end;
 
end.