1:

PaintGradient(Paintbox1.Canvas, Paintbox1.ClientRect, clRed, clYellow, goLeft2Right)                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  Colors: TGradRow;
begin
  setlength(Colors, 6);

  Colors[0] := clBlue;
  Colors[1] := clGreen;
  Colors[2] := clYellow;
  Colors[3] := clMaroon;
  Colors[4] := clRed;
  Colors[5] := clGreen;

  DrawGradRow(Paintbox1.Canvas, Paintbox1.Clientrect, Colors, goLeft2Right);
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:

unit Gradient;

interface

uses Windows, Graphics, Math;

type
  TGradientOrientation = (goLeft2Right, goTop2Bottom, goRadInner2Outer);
  TGradRow = array of TColor;

procedure PaintGradient (GradCanvas: TCanvas; GradRect: TRect; CStart, CEnd: TColor; 
  Orientation: TGradientOrientation; Flip: Boolean = False);
procedure DrawGradRow(GradCanvas: TCanvas; GradRect: TRect; Colors: TGradRow; 
  Orientation: TGradientOrientation; Flip: Boolean = False);

implementation

{*********************************************************
 Creator: Tweafis (c) 2003
 Procedure: PaintGradient;
   Draws a gradient in a rectangular shape
   on a TCanvas structure.

 Parameters:
   GradCanvas: The canvas to paint on
   GradRect: The Rect, which the gradient is drawn in
   CStart, CEnd: The start- and endcolor of the gradient
   Orientation: the orientation of the gradient (TGradientOrientation)
   Flip: When yes, The Gradient is Flipped. Default=False

 Other Things To Know:
   1) If Orientation is higher than the max value, it is
      automatically getting a right value per mod
*********************************************************}

procedure PaintGradient(GradCanvas: TCanvas; GradRect: TRect; CStart, CEnd: TColor; 
  Orientation: TGradientOrientation; Flip: Boolean = False);
var
  tmpCol: TColor;
  ar,ag,ab: integer;
  sr,sg,sb, er,eg,eb: integer;
  uspsr, uspsg, uspsb: double;

  GradLen: Integer;

  radius: real;

  x, y: Integer;
  mx, my: Integer;

//  P: PByteArray;

begin
  if Flip then begin
    tmpCol := CStart;
    CStart := CEnd;
    CEnd := tmpCol;
  end;

  sr := GetRValue(CStart);
  sg := GetGValue(CStart);
  sb := GetBValue(CStart);

  er := GetRValue(CEnd);
  eg := GetGValue(CEnd);
  eb := GetBValue(CEnd);

  if Orientation in [goLeft2Right,goTop2Bottom] then begin // linear
    with GradCanvas do begin
      if Orientation = goLeft2Right then
        GradLen := GradRect.Right - GradRect.Left
      else
        GradLen := GradRect.Bottom - GradRect.Top;

      if GradLen = 0 then Exit;

      uspsr:= (er-sr) / GradLen;
      uspsg:= (eg-sg) / GradLen;
      uspsb:= (eb-sb) / GradLen;

      for x:=0 to GradLen do begin
        ar := round(sr+uspsr*x);
        ag := round(sg+uspsg*x);
        ab := round(sb+uspsb*x);

        Pen.Color := RGB(ar, ag, ab);

        if Orientation = goLeft2Right then begin
          MoveTo(GradRect.Left+x, GradRect.Top);
          LineTo(GradRect.Left+x, GradRect.Bottom);
        end
        else begin
          MoveTo(GradRect.Left, GradRect.Top+x);
          LineTo(GradRect.Right, GradRect.Top+x);
        end;
      end;
    end;
  end
  else with GradCanvas do begin
    GradLen := min(GradRect.Right-GradRect.Left,GradRect.Bottom-GradRect.Top) div 2; // Radius

    if GradLen = 0 then Exit;

    uspsr:= (er-sr) / GradLen;
    uspsg:= (eg-sg) / GradLen;
    uspsb:= (eb-sb) / GradLen;

    mx := GradRect.Left+GradLen;
    my := GradRect.Top+GradLen;

    for y := GradRect.Top to GradRect.Bottom do begin
      for x := GradRect.Left to GradRect.Right do begin
        radius := sqrt((mx-x)*(mx-x) + (my-y)*(my-y));
        if radius < GradLen then begin
          ar := round(sr+uspsr*radius);
          ag := round(sg+uspsg*radius);
          ab := round(sb+uspsb*radius);

          Pixels[x,y] := RGB(ar,ag,ab);
        end;
      end;
    end;
  end;
end;

{ Procedur zum Zeichnen eines Langen Verlaufes (mit gleicher aufteilung) }

procedure DrawGradRow(GradCanvas: TCanvas; GradRect: TRect; Colors: TGradRow; 
  Orientation: TGradientOrientation; Flip: Boolean = False);
var
  x:integer;
  lRect: TRect;
  GradRectWidth,
  OneRectWidth: Integer;
  tmpGradRow: TGradRow;

begin
  if not (Orientation in [goLeft2Right, goTop2Bottom]) then exit;
  if High(Colors) < 1 then exit;

  case Orientation of
    goLeft2Right:
      GradRectWidth := GradRect.Right-GradRect.Left;
    goTop2Bottom:
      GradRectWidth := GradRect.Bottom-GradRect.Top;
  end;

  if Flip then begin
    setlength(tmpGradRow, High(Colors));
    for x:=0 to High(Colors)+1 do
      tmpGradRow[x] := Colors[x];
    for x:=High(tmpGradRow)+1 downto 0 do
      Colors[x] := tmpGradRow[(High(tmpGradRow)+1)-x];
  end;

  OneRectWidth := GradRectWidth div High(Colors);

  for x:=0 to High(Colors) do begin
    case Orientation of
      goLeft2Right: begin
          lRect := GradRect;
          lRect.Left := GradRect.Left+OneRectWidth*x;
          lRect.Right := lRect.Left+OneRectWidth;
        end;
      goTop2Bottom: begin
          lRect := GradRect;
          lRect.Top := GradRect.Top+OneRectWidth*x;
          lRect.Bottom := lRect.Top+OneRectWidth;
        end;
    end;

    PaintGradient(GradCanvas, lRect, Colors[x], Colors[x+1], Orientation);
  end;
end;

end.