home *** CD-ROM | disk | FTP | other *** search
- unit SRGrad;
-
- { TSRGradient (C)opyright 2001 Version 1.30
- 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 : 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.
-