Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kolekce/d123456/SIMONS.ZIP/Units/SRGrad.pas

Pascal/Delphi Source File | 2001-07-28 | 13.7 KB | 476 lines

unit SRGrad;

{ TSRGradient (C)opyright 2001 Version 1.30
  Autor : Simon Reinhardt
  eMail : [e-mail]
  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 : Integer;
begin
  YR := GetRValue(FStartColor);
  YG := GetGValue(FStartColor);
  YB := GetBValue(FStartColor);
  SR := YR;
  SG := YG;
  SB := YB;
  DR := GetRValue(FEndColor)-SR;
  DG := GetGValue(FEndColor)-SG;
  DB := GetBValue(FEndColor)-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.