Автор: Dimka Maslov
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Плавный переход одного цвета в другой

Две процедуры, служащие для отображения прямоугольников с поавным переходом
цветов. Первая процедура рисует вертикальный переход, вторая - горизонтальный.

Параметры процедур:
Canvas - задаёт графический контекст объекта для рисования
Left, Top, Width, Height - границы закрашиваемого прямоугольника
NonGradientArea - ширина области, закрашиваемой цветом Color1 (cм. ниже).
При положительном значении этого параметра, область располагается сверху или
справа, при отрицательном - снизу или слева.
FrameColor - цвет рамки прямоугольника
Color1 - начальный цвет заливки
Color2 - конечный цвет заливки

Зависимости: Windows, SysUtils, Classes, Graphics
Автор:       Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright:   Dimka Maslov
Дата:        11 июня 2003 г.
***************************************************** }

function GetColor(Color: Integer): Integer; register;
asm
   cmp eax, 0
   jge @@10
   and eax, 000000FFH
   push eax
   call GetSysColor
@@10:
end;

procedure VDrawGradientRect(Canvas: TCanvas; Left, Top, Width, Height: Integer;
  NonGradientArea: Integer; FrameColor, Color1, Color2: TColor);
var
  Mid: Integer;
  Color: TColor;
  C1: array[0..3] of Byte absolute Color1;
  C2: array[0..3] of Byte absolute Color2;
  C: array[0..3] of Byte absolute Color;
  i, j, X1, Y1, X2, Y2, Y0, L, X11, X21: Integer;
begin
  X1 := Left;
  Y1 := Top;
  X2 := Left + Width;
  Y2 := Top + Height;
  Color1 := GetColor(Color1);
  Color2 := GetColor(Color2);
  with Canvas do
  begin
    if NonGradientArea < 0 then
    begin
      Mid := Y2 + NonGradientArea;
      Y0 := Y1 + 1;
      L := Mid - Y0;
      X11 := X1 + 1;
      X21 := X2 - 1;
      for i := Y1 + 1 to Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - Y0), L);
        Pen.Color := Color;
        MoveTo(X11, i);
        LineTo(X21, i);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Mid, X2, Y2);
    end
    else
    begin
      Mid := NonGradientArea;
      Pen.Style := psSolid;
      Y0 := Y2 - 2;
      L := Mid - Y0;
      X11 := X1 + 1;
      X21 := X2 - 1;
      for i := Y2 - 2 downto Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - Y0), L);
        Pen.Color := Color;
        MoveTo(X11, i);
        LineTo(X21, i);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Y1 + 1, X2, Mid + 1);
    end;
    Pen.Color := FrameColor;
    Pen.Style := psSolid;
    MoveTo(X1, Y1);
    LineTo(X2 - 1, Y1);
    LineTo(X2 - 1, Y2 - 1);
    LineTo(X1, Y2 - 1);
    LineTo(X1, Y1);
  end;
end;

procedure HDrawGradientRect(Canvas: TCanvas; Left, Top, Width, Height: Integer;
  NonGradientArea: Integer; FrameColor, Color1, Color2: TColor);
var
  Mid: Integer;
  Color: TColor;
  C1: array[0..3] of Byte absolute Color1;
  C2: array[0..3] of Byte absolute Color2;
  C: array[0..3] of Byte absolute Color;
  i, j, X1, Y1, X2, Y2, X0, L, Y11, Y21: Integer;
begin
  X1 := Left;
  Y1 := Top;
  X2 := Left + Width;
  Y2 := Top + Height;
  Color1 := GetColor(Color1);
  Color2 := GetColor(Color2);
  with Canvas do
  begin
    if NonGradientArea < 0 then
    begin
      Mid := X2 + NonGradientArea;
      X0 := X1 + 1;
      L := Mid - X0;
      Y11 := Y1 + 1;
      Y21 := Y2 - 1;
      Pen.Style := psSolid;
      for i := X0 to Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - X0), L);
        Pen.Color := Color;
        MoveTo(i, Y11);
        LineTo(i, Y21);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(Mid, Y11, X2, Y2);
    end
    else
    begin
      Mid := NonGradientArea;
      X0 := X2 - 2;
      L := Mid - X0;
      Y11 := Y1 + 1;
      Y21 := Y2 - 1;
      Pen.Style := psSolid;
      for i := X0 downto Mid do
      begin
        for j := 0 to 3 do
          C[j] := MulDiv(1, C2[j] * (Mid - i) + C1[j] * (i - X0), L);
        Pen.Color := Color;
        MoveTo(i, Y11);
        LineTo(i, Y21);
      end;
      Pen.Style := psClear;
      Brush.Color := Canvas.Pen.Color;
      Rectangle(X1 + 1, Y1 + 1, Mid + 1, Y2);
    end;
    Pen.Color := FrameColor;
    Pen.Style := psSolid;
    MoveTo(X1, Y1);
    LineTo(X2 - 1, Y1);
    LineTo(X2 - 1, Y2 - 1);
    LineTo(X1, Y2 - 1);
    LineTo(X1, Y1);
  end;
end;

Пример использования:

procedure TForm1.FormPaint(Sender: TObject);
begin
  VDrawGradientRect(Canvas, 0, 0, ClientWidth, ClientHeight, 0,
    clBtnFace, clHighlight);
end;