unit SRGrad;

{ TSRGradient (C)opyright 2001 Version 1.31
  Autor : Simon Reinhardt
  eMail : reinhardt@picsoft.de
  Internet : http://www.picsoft.de

  Diese Komponente erzeugt einen Farbverlauf. Sie ist abgeleitet
  von TGraphicControl und ist Public Domain, das Urheberrecht liegt
  aber beim Autor.

  Änderungen von Jürgen Probst:
  Die Prozeduren "TGradient.LoadColors" und "TGradient.DrawGradient" wurden
  verändert. Außerdem wurden die Typen "TStartColor" und "TEndColor" durch
  "TColor" ersetzt. "TGradStyle" hat nun zusätzlich die Werte "gsCornerTopLeft",
  "gsCornerTopRight", "gsCornerBottomRight", "gsCornerBottomLeft",
  "gsDiagonalRising" und "gsDiagonalFalling".
  Die Ellipse wird nun mit Pen.Style=psClear gezeichnet. Dadurch sind die Farb-
  übergänge fließender.
  In Zeile 327 werden die Linien von gsPyramid bis x=-1 gezeichnet, da sonst
  die erste Spalte nicht gemalt wird. }

interface

{$I SRDefine.inc}

uses
  {$IFDEF SR_Win32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} SysUtils, Messages,
  Classes, Graphics, Controls, Forms, dialogs;

type
  TGradDirection = (gdDownRight, gdUpLeft);
  TGradStyle = (gsCornerTopLeft, gsCornerTopRight,
                gsCornerBottomRight, gsCornerBottomLeft,
                gsDiagonalRising, gsDiagonalFalling,
                gsEllipse, gsHorizontal, gsPyramid, gsVertical);
  TStepWidth = 1..10;

  TSRGradient = class(TGraphicControl)
  private
    FBC         : array[0..255] of Longint;
    FBitmap     : TBitmap;
    FBuffered   : boolean;
    FDirection  : TGradDirection;
    FEndColor   : TColor;
    FOldWidth,
    FOldHeight  : integer;
    FStartColor : TColor;
    FStepWidth  : TStepWidth;
    FStyle      : TGradStyle;

    procedure LoadColors;
    procedure DrawGradient(ACanvas: TCanvas);

    procedure SetBuffered(newValue: boolean);
    procedure SetDirection(newValue: TGradDirection);
    procedure SetEndColor(newValue: TColor);
    procedure SetStartColor(newValue: TColor);
    procedure SetStepWidth(newValue: TStepWidth);
    procedure SetStyle(newValue: TGradStyle);
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_EraseBkgnd;

  protected
    procedure Paint; override;

  public
    constructor Create(AComponent: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;

  published
    property Align;
    {$IFDEF SR_Delphi5_Up}
    property Anchors;
    {$ENDIF}
    property Buffered : boolean read FBuffered write SetBuffered;
    property Direction : TGradDirection read FDirection write SetDirection;
    property EndColor : TColor read FEndColor write SetEndColor;
    property StartColor : TColor read FStartColor write SetStartColor;
    property StepWidth : TStepWidth read FStepWidth write SetStepWidth;
    property Style : TGradStyle read FStyle write SetStyle;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

{$IFDEF SR_Delphi2_Up}
{$R *.D32}
{$ELSE}
{$R *.D16}
{$ENDIF}

procedure TSRGradient.Loaded;
begin
  inherited Loaded;
end;

procedure TSRGradient.LoadColors;
var X,YR,YG,YB,SR,
    SG,SB,DR,DG,DB,
    StartClr,EndClr : integer;
begin
  StartClr:=ColorToRGB(FStartColor);
  YR := GetRValue(StartClr);
  YG := GetGValue(StartClr);
  YB := GetBValue(StartClr);
  SR := YR;
  SG := YG;
  SB := YB;
  EndClr:=ColorToRGB(FEndColor);
  DR := GetRValue(EndClr)-SR;
  DG := GetGValue(EndClr)-SG;
  DB := GetBValue(EndClr)-SB;
  if (FDirection = gdDownRight) then
    for X := 0 to 255 do begin
      FBC[X] := RGB( YR, YG, YB);
      YR := SR + round(DR / 255 * X);
      YG := SG + round(DG / 255 * X);
      YB := SB + round(DB / 255 * X);
    end
    else for X := 255 downto 0 do begin
      FBC[X] := RGB( YR, YG, YB);
      YR := SR + round(DR / 255 * (255-X));
      YG := SG + round(DG / 255 * (255-X));
      YB := SB + round(DB / 255 * (255-X));
    end;
end;

procedure TSRGradient.DrawGradient(ACanvas: TCanvas);
var
  TempRect   : TRect;
  TempStepV,
  TempStepH  : Single;
  ColorCode,
  TempLeft,
  TempTop,
  TempHeight,
  TempWidth,
  ECount,i   : integer;
  CornerPnts : array [0..5] of TPoint;
  DiagArray  : array [0..255, 0..3] of TPoint;
begin
  if FBuffered and (FStyle=gsEllipse) then begin
    TempRect:=Rect(0, 0, Width, Height);
    with ACanvas do begin
      Brush.Color:=clSilver;
      FillRect(TempRect);
    end;
  end;
  if FStyle in [gsHorizontal, gsVertical,
                gsCornerTopLeft, gsCornerTopRight,
                gsCornerBottomRight, gsCornerBottomLeft] then begin
    TempStepH := Width / 255;
    TempStepV := Height / 255;
    TempHeight := Trunc(TempStepV + 1);
    TempWidth := Trunc(TempStepH + 1);
    with ACanvas do begin
      TempTop := 0;
      TempLeft := 0;
      TempRect.Top := 0;
      TempRect.Bottom:= Height;
      TempRect.Left := 0;
      TempRect.Right:= Width;
      If not (Fstyle in [gsVertical, gsHorizontal]) then
        pen.Style:=psclear;
      for ColorCode := 0 to 255 do begin
        Brush.Color := FBC[ColorCode];

        if FStyle = gsVertical then begin
          TempRect.Top  := TempTop;
          TempRect.Bottom := TempTop + TempHeight;
        end

        else if FStyle = gsHorizontal then begin
          TempRect.Left  := TempLeft;
          TempRect.Right := TempLeft + TempWidth;
        end

        else if FStyle = gsCornerTopLeft then begin
          TempTop := Trunc(TempStepV * (255-ColorCode));
          TempLeft := Trunc(TempStepH * (255-ColorCode));
          CornerPnts[0]:=Point(0, TempTop);
          CornerPnts[1]:=Point(TempLeft, TempTop);
          CornerPnts[2]:=Point(TempLeft, 0);
          CornerPnts[3]:=Point(TempLeft+TempWidth, 0);
          CornerPnts[4]:=Point(TempLeft+TempWidth, TempTop+TempHeight);
          CornerPnts[5]:=Point(0, TempTop+TempHeight);
        end

        else if FStyle = gsCornerTopRight then begin
          TempTop := Trunc(TempStepV * (255-ColorCode));
          TempLeft := Trunc(TempStepH * ColorCode);
          CornerPnts[0]:=Point(TempLeft+TempWidth, 0);
          CornerPnts[1]:=Point(TempLeft+TempWidth, TempTop);
          CornerPnts[2]:=Point(Width, TempTop);
          CornerPnts[3]:=Point(Width, TempTop+TempHeight);
          CornerPnts[4]:=Point(TempLeft, TempTop+TempHeight);
          CornerPnts[5]:=Point(TempLeft, 0);
        end

        else if FStyle = gsCornerBottomRight then begin
          TempTop := Trunc(TempStepV * ColorCode);
          TempLeft := Trunc(TempStepH * ColorCode);
          CornerPnts[0]:=Point(Width, TempTop+TempHeight);
          CornerPnts[1]:=Point(TempLeft+TempWidth, TempTop+TempHeight);
          CornerPnts[2]:=Point(TempLeft+TempWidth, Height);
          CornerPnts[3]:=Point(TempLeft, Height);
          CornerPnts[4]:=Point(TempLeft, TempTop);
          CornerPnts[5]:=Point(Width, TempTop);
        end

        else if FStyle = gsCornerBottomLeft then begin
          TempTop := Trunc(TempStepV * ColorCode);
          TempLeft := Trunc(TempStepH * (255-ColorCode));
          CornerPnts[0]:=Point(TempLeft, Height);
          CornerPnts[1]:=Point(TempLeft, TempTop+TempHeight);
          CornerPnts[2]:=Point(0, TempTop+TempHeight);
          CornerPnts[3]:=Point(0, TempTop);
          CornerPnts[4]:=Point(TempLeft+TempWidth, TempTop);
          CornerPnts[5]:=Point(TempLeft+TempWidth, Height);
        end;

        if FStyle in [gsVertical, gsHorizontal] then
          FillRect(TempRect)
        else
          Polygon(CornerPnts);

        if FStyle = gsVertical then
          TempTop := Trunc(TempStepV * ColorCode)
        else if FStyle = gsHorizontal then
          TempLeft := Trunc(TempStepH * ColorCode);
      end;
    end;
  end;
  if FStyle in [gsDiagonalFalling, gsDiagonalRising] then begin
    TempStepH := Width / 127;
    TempStepV := Height / 127;
    TempHeight := Trunc(TempStepV+1);
    TempWidth := Trunc(TempStepH+1);

    If FStyle=gsDiagonalFalling then Begin
      for i := 0 to 127 do begin
        TempLeft := Trunc(TempStepH * i);
        Diagarray[i, 0]:=Point(TempLeft, 0);
        Diagarray[i, 1]:=Point(TempLeft+TempWidth, 0);
        Diagarray[i+128, 3]:=Point(TempLeft, Height);
        Diagarray[i+128, 2]:=Point(TempLeft+TempWidth, Height);
      end;
      for i := 0 to 127 do begin
        TempTop := Trunc(TempStepV * i);
        Diagarray[i, 3]:=Point(0, TempTop);
        Diagarray[i, 2]:=Point(0, TempTop+TempHeight);
        Diagarray[i+128, 0]:=Point(Width, TempTop);
        Diagarray[i+128, 1]:=Point(Width, TempTop+TempHeight);
      end;
    end

    else Begin
      for i := 0 to 127 do begin
        TempLeft := Trunc(TempStepH * i);
        Diagarray[i, 0]:=Point(TempLeft, Height);
        Diagarray[i, 1]:=Point(TempLeft+TempWidth, Height);
        Diagarray[i+128, 3]:=Point(TempLeft, 0);
        Diagarray[i+128, 2]:=Point(TempLeft+TempWidth, 0);
      end;
      for i := 0 to 127 do begin
        TempTop := Trunc(TempStepV * (127-i));
        Diagarray[i, 3]:=Point(0, TempTop+TempHeight);
        Diagarray[i, 2]:=Point(0, TempTop);
        Diagarray[i+128, 0]:=Point(Width, TempTop+TempHeight);
        Diagarray[i+128, 1]:=Point(Width, TempTop);
      end;
    end;

    with ACanvas do begin
      Pen.Style:=psclear;
      For ColorCode := 0 to 255 do Begin
        Brush.Color := FBC[ColorCode];
        Polygon(Diagarray[ColorCode]);
      End;
    end;
  end;

  if FStyle=gsEllipse then begin
    with ACanvas do begin
      TempTop := 1;
      TempLeft := 1;
      Pen.Width:=1;
      Pen.Style:=psclear;
      ECount:=(Width div 2)-2;
      TempStepV:=Height/Width;
      TempStepH:=255/ECount;
      i:=2;
      while i<ECount do begin
        ColorCode:=trunc(TempStepH*i);
        Brush.Color:=FBC[ColorCode];
        Ellipse(TempLeft, TempTop, Width-TempLeft, Height-TempTop);
        TempTop := Trunc(TempStepV * i);
        TempLeft := i;
        i:=i+FStepWidth;
      end;
    end;
  end;

  if FStyle=gsPyramid then begin
    with ACanvas do begin
      TempLeft := Width div 2;
      TempTop := Height div 2;
      Pen.Width:=FStepWidth;
      Pen.Style:=psSolid;
      ECount:=Width+Height;
      TempStepH:=255/ECount;
      i:=0;
      while i<=Width do begin
        ColorCode:=trunc(TempStepH*i);
        Pen.Color := FBC[ColorCode];
        MoveTo(i, 0);
        LineTo(TempLeft, TempTop);
        ColorCode:=trunc(TempStepH*(i+Height));
        Pen.Color := FBC[ColorCode];
        LineTo(i, Height);
        i:=i+FStepWidth;
      end;
      i:=0;
      while i<=Height do begin
        ColorCode:=trunc(TempStepH*(i+Width));
        Pen.Color := FBC[ColorCode];
        MoveTo(Width, i);
        LineTo(TempLeft, TempTop);
        ColorCode:=trunc(TempStepH*i);
        Pen.Color := FBC[ColorCode];
        LineTo(-1, i);
        i:=i+FStepWidth;
      end;
    end;
  end;
end;

procedure TSRGradient.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

constructor TSRGradient.Create(AComponent: TComponent);
begin
  inherited Create(AComponent);

  FBuffered := true;
  FEndColor := clBlack;
  FDirection := gdDownRight;
  FStartColor := clBlue;
  FStepWidth := 1;
  FStyle := gsVertical;
  Width:=100;
  Height:=80;
  FOldWidth := 0;
  FOldHeight := 0;

  FBitmap := TBitmap.Create;
  LoadColors;
end;

destructor TSRGradient.Destroy;
begin
  if FBuffered and assigned(FBitmap) then begin
    FBitmap.Free;
    FBitmap:=nil;
  end;
  inherited Destroy;
end;

procedure TSRGradient.SetBuffered(newValue: boolean);
begin
  if FBuffered<>newValue then begin
    FBuffered:=newValue;
    if FBuffered then
      FBitmap:=TBitmap.Create;
    if not FBuffered and assigned(FBitmap) then begin
      FBitmap.Free;
      FBitmap:=nil;
    end;
    FOldWidth:=0;
    Invalidate;
  end;
end;

procedure TSRGradient.SetDirection(newValue: TGradDirection);
begin
  if FDirection<>newValue then begin
    FDirection:=newValue;
    FOldWidth:=0;
    LoadColors;
    Invalidate;
  end;
end;

procedure TSRGradient.SetEndColor(newValue: TColor);
begin
  if FEndColor<>newValue then begin
    FEndColor:=newValue;
    FOldWidth:=0;
    LoadColors;
    Invalidate;
  end;
end;

procedure TSRGradient.SetStartColor(newValue: TColor);
begin
  if FStartColor<>newValue then begin
    FStartColor:=newValue;
    FOldWidth:=0;
    LoadColors;
    Invalidate;
  end;
end;

procedure TSRGradient.SetStepWidth(newValue: TStepWidth);
begin
  if (FStepWidth<>newValue) and (newValue>=1) and (newValue<=10) then begin
    FStepWidth:=newValue;
    FOldWidth:=0;
    Invalidate;
  end;
end;

procedure TSRGradient.SetStyle(newValue: TGradStyle);
begin
  if FStyle<>newValue then begin
    FStyle:=newValue;
    FOldWidth:=0;
    Invalidate;
  end;
end;

procedure TSRGradient.Paint;
var BmpRect : TRect;
begin
  if FBuffered and assigned(FBitmap) then begin
    if (FOldWidth<>Width) or (FOldHeight<>Height) then begin
      FOldWidth:=Width;
      FOldHeight:=Height;
      FBitmap.Width:=Width;
      FBitmap.Height:=Height;
      DrawGradient(FBitmap.Canvas);
    end;
    if FStyle=gsEllipse then begin
      BmpRect:=Rect(0, 0, Self.Width-1, Self.Height-1);
      with Self.Canvas do begin
        Brush.Style:=bsClear;
        FillRect(BmpRect);
        BrushCopy(BmpRect, FBitmap, BmpRect, clSilver);
      end;
    end
    else
      BitBlT(Self.Canvas.Handle,
             0, 0, Width, Height,
             FBitmap.Canvas.Handle,
             0, 0, SrcCopy);
  end
  else
    DrawGradient(Self.Canvas);
end;

procedure Register;
begin
  RegisterComponents('Simon', [TSRGradient]);
end;

end.
