[lazarus] Re: Gradient fill into corners

[Funky Beast]

Hi,

Try attached very old code.

HTH,
Funky Beast

//NColors == Number of steps per color transition
function CalColor(BeginCol, EndCol: TColor; var arColors: array of TColor; 
NColors: integer): Boolean;
var BeginRGB  : array[0..2] of Byte;
    RGBDifference  : array[0..2] of integer;
    R         : Byte;
    G         : Byte;
    B         : Byte;
    I         : Byte;
begin
 try
  BeginRGB[0] := GetRValue(ColorToRGB(BeginCol));
  BeginRGB[1] := GetGValue(ColorToRGB(BeginCol));
  BeginRGB[2] := GetBValue(ColorToRGB(BeginCol));

  RGBDifference[0] := GetRValue(ColorToRGB(EndCol)) - BeginRGB[0];
  RGBDifference[1] := GetGValue(ColorToRGB(EndCol)) - BeginRGB[1];
  RGBDifference[2] := GetBValue(ColorToRGB(EndCol)) - BeginRGB[2];
  for i:=0 to 255 do
   begin
    R := BeginRGB[0] + MulDiv(I, RGBDifference[0], NColors);
    G := BeginRGB[1] + MulDiv(I, RGBDifference[1], NColors);
    B := BeginRGB[2] + MulDiv(I, RGBDifference[2], NColors);
    arColors[i] := RGB(R, G, B);
   end;//End for-loop i

  Result := True;
 except
  Result := False;
 end;//End try-except
end;

//ColorsBetween == A list of color strings between begin and end colors.
//accepts color constants like 'clRed', 'clBlue', etc, or hex values like 
'$0FFFFF'.

procedure GradientBottomCorner(Canvas: TCanvas; iWidth, iHeight: Integer; 
BeginCol,
 EndCol: TColor; ColorsBetween: TStrings; NColors: Integer);
var Rc: TRect;
    i, j: integer;
    X, Y: integer;
    ColorWidth, ColorHeight: integer;
    S: TStrings;
    arColors: array[0..255] of TColor;
begin
 if ((iWidth < 0) or (iHeight < 0)) then Exit;
 S := TStringlist.Create;
 try
  S.Add(ColorToString(BeginCol));
  S.AddStrings(ColorsBetween);
  S.Add(ColorToString(EndCol));
  Rc.Top := 0;
  Rc.Bottom := iHeight;

  with Canvas do
   begin
    ColorWidth := (iWidth div (S.Count-1));
    ColorHeight := (iHeight div (S.Count-1));
    for j:=0 to S.Count-2 do
     begin
      CalColor(StringToColor(S[j]), StringToColor(S[j+1]), arColors, NColors);
      X := ((iWidth div (S.Count-1)) * j);
      Y := ((iHeight div (S.Count-1)) * j);
      for i:=0 to NColors do
       begin
        Rc.Left := X + MulDiv(i, ColorWidth, NColors);
        Rc.Top := Y + MulDiv(i, ColorHeight, NColors);
        Rc.Right := iWidth;
        Rc.Bottom := iHeight;
        while (Rc.Left <= (X + MulDiv(i + 1, ColorWidth, NColors))) do
         begin
          Brush.Color := arColors[i];
          Pen.Color := arColors[i];
          MoveTo(Rc.Left, Rc.Bottom);
          LineTo(Rc.Left, Rc.Top);
          LineTo(Rc.Right, Rc.Top);
          Rc.Left := Rc.Left + 1;
          Rc.Top := Rc.Top + 1;
         end;//End while-loop
        if (Rc.Top <= (Y + MulDiv(i + 1, ColorHeight, NColors))) then
         begin
          while (Rc.Top <= (Y + MulDiv(i + 1, ColorHeight, NColors))) do
           begin
            Brush.Color := arColors[i];
            Pen.Color := arColors[i];
            MoveTo(Rc.Left, Rc.Top);
            LineTo(Rc.Right, Rc.Top);
            Rc.Top := Rc.Top + 1;
           end;//End while-loop
         end;//End if (Rc.Top <= (Y + MulDiv(i + 1, ColorHeight, NColors)))
       end;//End for-loop i
     end;//End for-loop j
    Pen.Color := EndCol;
    Brush.Color := EndCol;
   end;//End with Canvas
 finally
  FreeAndNil(S);
 end;//End try-finally
end;