home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 March / Chip_2002-03_cd1.bin / zkuste / delphi / kolekce / d123456 / SIMONS.ZIP / Units / SRGrad.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-07-28  |  13.7 KB  |  476 lines

  1. unit SRGrad;
  2.  
  3. { TSRGradient (C)opyright 2001 Version 1.30
  4.   Autor : Simon Reinhardt
  5.   eMail : reinhardt@picsoft.de
  6.   Internet : http://www.picsoft.de
  7.  
  8.   Diese Komponente erzeugt einen Farbverlauf. Sie ist abgeleitet
  9.   von TGraphicControl und ist Public Domain, das Urheberrecht liegt
  10.   aber beim Autor.
  11.  
  12.   ─nderungen von Jⁿrgen Probst:
  13.   Die Prozeduren "TGradient.LoadColors" und "TGradient.DrawGradient" wurden
  14.   verΣndert. Au▀erdem wurden die Typen "TStartColor" und "TEndColor" durch
  15.   "TColor" ersetzt. "TGradStyle" hat nun zusΣtzlich die Werte "gsCornerTopLeft",
  16.   "gsCornerTopRight", "gsCornerBottomRight", "gsCornerBottomLeft",
  17.   "gsDiagonalRising" und "gsDiagonalFalling".
  18.   Die Ellipse wird nun mit Pen.Style=psClear gezeichnet. Dadurch sind die Farb-
  19.   ⁿbergΣnge flie▀ender.
  20.   In Zeile 327 werden die Linien von gsPyramid bis x=-1 gezeichnet, da sonst
  21.   die erste Spalte nicht gemalt wird. }
  22.  
  23. interface
  24.  
  25. {$I SRDefine.inc}
  26.  
  27. uses
  28.   {$IFDEF SR_Win32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} SysUtils, Messages,
  29.   Classes, Graphics, Controls, Forms, dialogs;
  30.  
  31. type
  32.   TGradDirection = (gdDownRight, gdUpLeft);
  33.   TGradStyle = (gsCornerTopLeft, gsCornerTopRight,
  34.                 gsCornerBottomRight, gsCornerBottomLeft,
  35.                 gsDiagonalRising, gsDiagonalFalling,
  36.                 gsEllipse, gsHorizontal, gsPyramid, gsVertical);
  37.   TStepWidth = 1..10;
  38.  
  39.   TSRGradient = class(TGraphicControl)
  40.   private
  41.     FBC         : array[0..255] of Longint;
  42.     FBitmap     : TBitmap;
  43.     FBuffered   : boolean;
  44.     FDirection  : TGradDirection;
  45.     FEndColor   : TColor;
  46.     FOldWidth,
  47.     FOldHeight  : integer;
  48.     FStartColor : TColor;
  49.     FStepWidth  : TStepWidth;
  50.     FStyle      : TGradStyle;
  51.  
  52.     procedure LoadColors;
  53.     procedure DrawGradient(ACanvas: TCanvas);
  54.  
  55.     procedure SetBuffered(newValue: boolean);
  56.     procedure SetDirection(newValue: TGradDirection);
  57.     procedure SetEndColor(newValue: TColor);
  58.     procedure SetStartColor(newValue: TColor);
  59.     procedure SetStepWidth(newValue: TStepWidth);
  60.     procedure SetStyle(newValue: TGradStyle);
  61.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_EraseBkgnd;
  62.  
  63.   protected
  64.     procedure Paint; override;
  65.  
  66.   public
  67.     constructor Create(AComponent: TComponent); override;
  68.     destructor Destroy; override;
  69.     procedure Loaded; override;
  70.  
  71.   published
  72.     property Align;
  73.     {$IFDEF SR_Delphi5_Up}
  74.     property Anchors;
  75.     {$ENDIF}
  76.     property Buffered : boolean read FBuffered write SetBuffered;
  77.     property Direction : TGradDirection read FDirection write SetDirection;
  78.     property EndColor : TColor read FEndColor write SetEndColor;
  79.     property StartColor : TColor read FStartColor write SetStartColor;
  80.     property StepWidth : TStepWidth read FStepWidth write SetStepWidth;
  81.     property Style : TGradStyle read FStyle write SetStyle;
  82.     property OnClick;
  83.     property OnDblClick;
  84.     property OnDragDrop;
  85.     property OnDragOver;
  86.     property OnEndDrag;
  87.     property OnMouseDown;
  88.     property OnMouseMove;
  89.     property OnMouseUp;
  90.   end;
  91.  
  92. procedure Register;
  93.  
  94. implementation
  95.  
  96. {$IFDEF SR_Delphi2_Up}
  97. {$R *.D32}
  98. {$ELSE}
  99. {$R *.D16}
  100. {$ENDIF}
  101.  
  102. procedure TSRGradient.Loaded;
  103. begin
  104.   inherited Loaded;
  105. end;
  106.  
  107. procedure TSRGradient.LoadColors;
  108. var X,YR,YG,YB,SR,
  109.     SG,SB,DR,DG,DB : Integer;
  110. begin
  111.   YR := GetRValue(FStartColor);
  112.   YG := GetGValue(FStartColor);
  113.   YB := GetBValue(FStartColor);
  114.   SR := YR;
  115.   SG := YG;
  116.   SB := YB;
  117.   DR := GetRValue(FEndColor)-SR;
  118.   DG := GetGValue(FEndColor)-SG;
  119.   DB := GetBValue(FEndColor)-SB;
  120.   if (FDirection = gdDownRight) then
  121.     for X := 0 to 255 do begin
  122.       FBC[X] := RGB( YR, YG, YB);
  123.       YR := SR + round(DR / 255 * X);
  124.       YG := SG + round(DG / 255 * X);
  125.       YB := SB + round(DB / 255 * X);
  126.     end
  127.     else for X := 255 downto 0 do begin
  128.       FBC[X] := RGB( YR, YG, YB);
  129.       YR := SR + round(DR / 255 * (255-X));
  130.       YG := SG + round(DG / 255 * (255-X));
  131.       YB := SB + round(DB / 255 * (255-X));
  132.     end;
  133. end;
  134.  
  135. procedure TSRGradient.DrawGradient(ACanvas: TCanvas);
  136. var
  137.   TempRect   : TRect;
  138.   TempStepV,
  139.   TempStepH  : Single;
  140.   ColorCode,
  141.   TempLeft,
  142.   TempTop,
  143.   TempHeight,
  144.   TempWidth,
  145.   ECount,i   : integer;
  146.   CornerPnts : array [0..5] of TPoint;
  147.   DiagArray  : array [0..255, 0..3] of TPoint;
  148. begin
  149.   if FBuffered and (FStyle=gsEllipse) then begin
  150.     TempRect:=Rect(0, 0, Width, Height);
  151.     with ACanvas do begin
  152.       Brush.Color:=clSilver;
  153.       FillRect(TempRect);
  154.     end;
  155.   end;
  156.   if FStyle in [gsHorizontal, gsVertical,
  157.                 gsCornerTopLeft, gsCornerTopRight,
  158.                 gsCornerBottomRight, gsCornerBottomLeft] then begin
  159.     TempStepH := Width / 255;
  160.     TempStepV := Height / 255;
  161.     TempHeight := Trunc(TempStepV + 1);
  162.     TempWidth := Trunc(TempStepH + 1);
  163.     with ACanvas do begin
  164.       TempTop := 0;
  165.       TempLeft := 0;
  166.       TempRect.Top := 0;
  167.       TempRect.Bottom:= Height;
  168.       TempRect.Left := 0;
  169.       TempRect.Right:= Width;
  170.       If not (Fstyle in [gsVertical, gsHorizontal]) then
  171.         pen.Style:=psclear;
  172.       for ColorCode := 0 to 255 do begin
  173.         Brush.Color := FBC[ColorCode];
  174.  
  175.         if FStyle = gsVertical then begin
  176.           TempRect.Top  := TempTop;
  177.           TempRect.Bottom := TempTop + TempHeight;
  178.         end
  179.  
  180.         else if FStyle = gsHorizontal then begin
  181.           TempRect.Left  := TempLeft;
  182.           TempRect.Right := TempLeft + TempWidth;
  183.         end
  184.  
  185.         else if FStyle = gsCornerTopLeft then begin
  186.           TempTop := Trunc(TempStepV * (255-ColorCode));
  187.           TempLeft := Trunc(TempStepH * (255-ColorCode));
  188.           CornerPnts[0]:=Point(0, TempTop);
  189.           CornerPnts[1]:=Point(TempLeft, TempTop);
  190.           CornerPnts[2]:=Point(TempLeft, 0);
  191.           CornerPnts[3]:=Point(TempLeft+TempWidth, 0);
  192.           CornerPnts[4]:=Point(TempLeft+TempWidth, TempTop+TempHeight);
  193.           CornerPnts[5]:=Point(0, TempTop+TempHeight);
  194.         end
  195.  
  196.         else if FStyle = gsCornerTopRight then begin
  197.           TempTop := Trunc(TempStepV * (255-ColorCode));
  198.           TempLeft := Trunc(TempStepH * ColorCode);
  199.           CornerPnts[0]:=Point(TempLeft+TempWidth, 0);
  200.           CornerPnts[1]:=Point(TempLeft+TempWidth, TempTop);
  201.           CornerPnts[2]:=Point(Width, TempTop);
  202.           CornerPnts[3]:=Point(Width, TempTop+TempHeight);
  203.           CornerPnts[4]:=Point(TempLeft, TempTop+TempHeight);
  204.           CornerPnts[5]:=Point(TempLeft, 0);
  205.         end
  206.  
  207.         else if FStyle = gsCornerBottomRight then begin
  208.           TempTop := Trunc(TempStepV * ColorCode);
  209.           TempLeft := Trunc(TempStepH * ColorCode);
  210.           CornerPnts[0]:=Point(Width, TempTop+TempHeight);
  211.           CornerPnts[1]:=Point(TempLeft+TempWidth, TempTop+TempHeight);
  212.           CornerPnts[2]:=Point(TempLeft+TempWidth, Height);
  213.           CornerPnts[3]:=Point(TempLeft, Height);
  214.           CornerPnts[4]:=Point(TempLeft, TempTop);
  215.           CornerPnts[5]:=Point(Width, TempTop);
  216.         end
  217.  
  218.         else if FStyle = gsCornerBottomLeft then begin
  219.           TempTop := Trunc(TempStepV * ColorCode);
  220.           TempLeft := Trunc(TempStepH * (255-ColorCode));
  221.           CornerPnts[0]:=Point(TempLeft, Height);
  222.           CornerPnts[1]:=Point(TempLeft, TempTop+TempHeight);
  223.           CornerPnts[2]:=Point(0, TempTop+TempHeight);
  224.           CornerPnts[3]:=Point(0, TempTop);
  225.           CornerPnts[4]:=Point(TempLeft+TempWidth, TempTop);
  226.           CornerPnts[5]:=Point(TempLeft+TempWidth, Height);
  227.         end;
  228.  
  229.         if FStyle in [gsVertical, gsHorizontal] then
  230.           FillRect(TempRect)
  231.         else
  232.           Polygon(CornerPnts);
  233.  
  234.         if FStyle = gsVertical then
  235.           TempTop := Trunc(TempStepV * ColorCode)
  236.         else if FStyle = gsHorizontal then
  237.           TempLeft := Trunc(TempStepH * ColorCode);
  238.       end;
  239.     end;
  240.   end;
  241.   if FStyle in [gsDiagonalFalling, gsDiagonalRising] then begin
  242.     TempStepH := Width / 127;
  243.     TempStepV := Height / 127;
  244.     TempHeight := Trunc(TempStepV+1);
  245.     TempWidth := Trunc(TempStepH+1);
  246.  
  247.     If FStyle=gsDiagonalFalling then Begin
  248.       for i := 0 to 127 do begin
  249.         TempLeft := Trunc(TempStepH * i);
  250.         Diagarray[i, 0]:=Point(TempLeft, 0);
  251.         Diagarray[i, 1]:=Point(TempLeft+TempWidth, 0);
  252.         Diagarray[i+128, 3]:=Point(TempLeft, Height);
  253.         Diagarray[i+128, 2]:=Point(TempLeft+TempWidth, Height);
  254.       end;
  255.       for i := 0 to 127 do begin
  256.         TempTop := Trunc(TempStepV * i);
  257.         Diagarray[i, 3]:=Point(0, TempTop);
  258.         Diagarray[i, 2]:=Point(0, TempTop+TempHeight);
  259.         Diagarray[i+128, 0]:=Point(Width, TempTop);
  260.         Diagarray[i+128, 1]:=Point(Width, TempTop+TempHeight);
  261.       end;
  262.     end
  263.  
  264.     else Begin
  265.       for i := 0 to 127 do begin
  266.         TempLeft := Trunc(TempStepH * i);
  267.         Diagarray[i, 0]:=Point(TempLeft, Height);
  268.         Diagarray[i, 1]:=Point(TempLeft+TempWidth, Height);
  269.         Diagarray[i+128, 3]:=Point(TempLeft, 0);
  270.         Diagarray[i+128, 2]:=Point(TempLeft+TempWidth, 0);
  271.       end;
  272.       for i := 0 to 127 do begin
  273.         TempTop := Trunc(TempStepV * (127-i));
  274.         Diagarray[i, 3]:=Point(0, TempTop+TempHeight);
  275.         Diagarray[i, 2]:=Point(0, TempTop);
  276.         Diagarray[i+128, 0]:=Point(Width, TempTop+TempHeight);
  277.         Diagarray[i+128, 1]:=Point(Width, TempTop);
  278.       end;
  279.     end;
  280.  
  281.     with ACanvas do begin
  282.       Pen.Style:=psclear;
  283.       For ColorCode := 0 to 255 do Begin
  284.         Brush.Color := FBC[ColorCode];
  285.         Polygon(Diagarray[ColorCode]);
  286.       End;
  287.     end;
  288.   end;
  289.  
  290.   if FStyle=gsEllipse then begin
  291.     with ACanvas do begin
  292.       TempTop := 1;
  293.       TempLeft := 1;
  294.       Pen.Width:=1;
  295.       Pen.Style:=psclear;
  296.       ECount:=(Width div 2)-2;
  297.       TempStepV:=Height/Width;
  298.       TempStepH:=255/ECount;
  299.       i:=2;
  300.       while i<ECount do begin
  301.         ColorCode:=trunc(TempStepH*i);
  302.         Brush.Color:=FBC[ColorCode];
  303.         Ellipse(TempLeft, TempTop, Width-TempLeft, Height-TempTop);
  304.         TempTop := Trunc(TempStepV * i);
  305.         TempLeft := i;
  306.         i:=i+FStepWidth;
  307.       end;
  308.     end;
  309.   end;
  310.  
  311.   if FStyle=gsPyramid then begin
  312.     with ACanvas do begin
  313.       TempLeft := Width div 2;
  314.       TempTop := Height div 2;
  315.       Pen.Width:=FStepWidth;
  316.       Pen.Style:=psSolid;
  317.       ECount:=Width+Height;
  318.       TempStepH:=255/ECount;
  319.       i:=0;
  320.       while i<=Width do begin
  321.         ColorCode:=trunc(TempStepH*i);
  322.         Pen.Color := FBC[ColorCode];
  323.         MoveTo(i, 0);
  324.         LineTo(TempLeft, TempTop);
  325.         ColorCode:=trunc(TempStepH*(i+Height));
  326.         Pen.Color := FBC[ColorCode];
  327.         LineTo(i, Height);
  328.         i:=i+FStepWidth;
  329.       end;
  330.       i:=0;
  331.       while i<=Height do begin
  332.         ColorCode:=trunc(TempStepH*(i+Width));
  333.         Pen.Color := FBC[ColorCode];
  334.         MoveTo(Width, i);
  335.         LineTo(TempLeft, TempTop);
  336.         ColorCode:=trunc(TempStepH*i);
  337.         Pen.Color := FBC[ColorCode];
  338.         LineTo(-1, i);
  339.         i:=i+FStepWidth;
  340.       end;
  341.     end;
  342.   end;
  343. end;
  344.  
  345. procedure TSRGradient.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  346. begin
  347.   Message.Result := 1;
  348. end;
  349.  
  350. constructor TSRGradient.Create(AComponent: TComponent);
  351. begin
  352.   inherited Create(AComponent);
  353.  
  354.   FBuffered := true;
  355.   FEndColor := clBlack;
  356.   FDirection := gdDownRight;
  357.   FStartColor := clBlue;
  358.   FStepWidth := 1;
  359.   FStyle := gsVertical;
  360.   Width:=100;
  361.   Height:=80;
  362.   FOldWidth := 0;
  363.   FOldHeight := 0;
  364.  
  365.   FBitmap := TBitmap.Create;
  366.   LoadColors;
  367. end;
  368.  
  369. destructor TSRGradient.Destroy;
  370. begin
  371.   if FBuffered and assigned(FBitmap) then begin
  372.     FBitmap.Free;
  373.     FBitmap:=nil;
  374.   end;
  375.   inherited Destroy;
  376. end;
  377.  
  378. procedure TSRGradient.SetBuffered(newValue: boolean);
  379. begin
  380.   if FBuffered<>newValue then begin
  381.     FBuffered:=newValue;
  382.     if FBuffered then
  383.       FBitmap:=TBitmap.Create;
  384.     if not FBuffered and assigned(FBitmap) then begin
  385.       FBitmap.Free;
  386.       FBitmap:=nil;
  387.     end;
  388.     FOldWidth:=0;
  389.     Invalidate;
  390.   end;
  391. end;
  392.  
  393. procedure TSRGradient.SetDirection(newValue: TGradDirection);
  394. begin
  395.   if FDirection<>newValue then begin
  396.     FDirection:=newValue;
  397.     FOldWidth:=0;
  398.     LoadColors;
  399.     Invalidate;
  400.   end;
  401. end;
  402.  
  403. procedure TSRGradient.SetEndColor(newValue: TColor);
  404. begin
  405.   if FEndColor<>newValue then begin
  406.     FEndColor:=newValue;
  407.     FOldWidth:=0;
  408.     LoadColors;
  409.     Invalidate;
  410.   end;
  411. end;
  412.  
  413. procedure TSRGradient.SetStartColor(newValue: TColor);
  414. begin
  415.   if FStartColor<>newValue then begin
  416.     FStartColor:=newValue;
  417.     FOldWidth:=0;
  418.     LoadColors;
  419.     Invalidate;
  420.   end;
  421. end;
  422.  
  423. procedure TSRGradient.SetStepWidth(newValue: TStepWidth);
  424. begin
  425.   if (FStepWidth<>newValue) and (newValue>=1) and (newValue<=10) then begin
  426.     FStepWidth:=newValue;
  427.     FOldWidth:=0;
  428.     Invalidate;
  429.   end;
  430. end;
  431.  
  432. procedure TSRGradient.SetStyle(newValue: TGradStyle);
  433. begin
  434.   if FStyle<>newValue then begin
  435.     FStyle:=newValue;
  436.     FOldWidth:=0;
  437.     Invalidate;
  438.   end;
  439. end;
  440.  
  441. procedure TSRGradient.Paint;
  442. var BmpRect : TRect;
  443. begin
  444.   if FBuffered and assigned(FBitmap) then begin
  445.     if (FOldWidth<>Width) or (FOldHeight<>Height) then begin
  446.       FOldWidth:=Width;
  447.       FOldHeight:=Height;
  448.       FBitmap.Width:=Width;
  449.       FBitmap.Height:=Height;
  450.       DrawGradient(FBitmap.Canvas);
  451.     end;
  452.     if FStyle=gsEllipse then begin
  453.       BmpRect:=Rect(0, 0, Self.Width-1, Self.Height-1);
  454.       with Self.Canvas do begin
  455.         Brush.Style:=bsClear;
  456.         FillRect(BmpRect);
  457.         BrushCopy(BmpRect, FBitmap, BmpRect, clSilver);
  458.       end;
  459.     end
  460.     else
  461.       BitBlT(Self.Canvas.Handle,
  462.              0, 0, Width, Height,
  463.              FBitmap.Canvas.Handle,
  464.              0, 0, SrcCopy);
  465.   end
  466.   else
  467.     DrawGradient(Self.Canvas);
  468. end;
  469.  
  470. procedure Register;
  471. begin
  472.   RegisterComponents('Simon', [TSRGradient]);
  473. end;
  474.  
  475. end.
  476.