Advanced Delphi Systems Code: ads

//Advanced Delphi Systems Code: ads_Gradient

{$N+}
Unit ads_Gradient;
{Copyright(c)2016 Advanced Delphi Systems

 Richard Maley
 Advanced Delphi Systems
 12613 Maidens Bower Drive
 Potomac, MD 20854 USA
 phone 301-840-1554
 dickmaley@advdelphisys.com

 The code herein can be used or modified by anyone.  Please retain references
 to Richard Maley at Advanced Delphi Systems.  If you make improvements to the
 code please send your improvements to dickmaley@advdelphisys.com so that the
 entire Delphi community can benefit.  All comments are welcome.
}

(*

UnitIndex Master Index Implementation Section Download Units

Description: ads_Gradient.pas
This unit contains the following routines.

Register TGradient.CreateGradient TGradient.Paint TGradient.SetEndingColor TGradient.SetGradientDirection TGradient.SetStartingColor

*)
interface

uses
  WinTypes, WinProcs, Messages,
  SysUtils, Classes, Controls,
  Forms, Menus, Graphics;

type
  TGradientDirection =
   (gdTopToBottom,gdLeftToRight,gdInsideOut,gdStretchInsideOut);

  TGradient = class(TGraphicControl)
  protected
    FGradBMP : hBitmap;
    fStartingColor : TColor;
    fEndingColor: TColor;
    fGradientDirection: TGradientDirection;
    fGradWidth,fGradHeight:integer;

    procedure Paint; override;
    procedure SetStartingColor(Value:TColor);
    procedure SetEndingColor(Value:TColor);
    procedure SetGradientDirection(Value:TGradientDirection);
  public
    procedure CreateGradient;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property GradientDirection:TGradientDirection read fGradientDirection write SetGradientDirection;
    property ColorStart: TColor read fStartingColor write SetStartingColor default clBlue;
    property ColorEnd: TColor read fEndingColor write SetEndingColor default clBlack;
    property Align;
    property DragCursor;
    property DragMode;
    property OnDragDrop;
    property OnClick;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

Uses ads_Exception;
Var
  ProcName : String = 'Unknown';
  UnitName : String = 'ads_Gradient';

//

Unit Description UnitIndex Master Index

procedure Register;
begin
  ProcName  := 'Register'; Try
  RegisterComponents('ads',[TGradient]);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

constructor TGradient.Create(AOwner: TComponent);
begin
  ProcName  := 'TGradient.Create'; Try
  inherited Create(AOwner);
  fEndingColor := clBlack;
  fStartingColor := clBlue;
  fGradBMP := 0;
  Width := 30;
  Height := 30;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

destructor TGradient.Destroy;
begin
  ProcName  := 'TGradient.Destroy'; Try
  if fGradBMP <> 0 then DeleteObject(fGradBMP);
  inherited Destroy;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

//

Unit Description UnitIndex Master Index

procedure TGradient.SetStartingColor(Value:TColor);
begin
  ProcName  := 'TGradient.SetStartingColor'; Try
  if Value<>fStartingColor then
     begin
     fStartingColor := Value;
     CreateGradient;
     Invalidate;
     end;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

//

Unit Description UnitIndex Master Index

procedure TGradient.SetEndingColor(Value:TColor);
begin
  ProcName  := 'TGradient.SetEndingColor'; Try
  if Value<>fEndingColor then
     begin
     fEndingColor := Value;
     CreateGradient;
     Invalidate;
     end;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

//

Unit Description UnitIndex Master Index

procedure TGradient.SetGradientDirection(Value:TGradientDirection);
begin
  ProcName  := 'TGradient.SetGradientDirection'; Try
  if Value<>fGradientDirection then
     begin
     fGradientDirection := Value;
     CreateGradient;
     Invalidate;
     end;
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

//

Unit Description UnitIndex Master Index

procedure TGradient.Paint;
var
  MemDC,PaintDC : HDC;
  OldBMP : hBitmap;
  R : TRect;
begin
  ProcName  := 'TGradient.Paint'; Try
  PaintDC := Canvas.Handle;
  if (fGradWidth<>Width) or (fGradHeight<>Height) then
     CreateGradient;
  if (fGradWidth=0) or (fGradHeight=0) then exit;
  MemDC := CreateCompatibleDC(PaintDC);
  OldBMP := SelectObject(MemDC,fGradBMP);
  R := Rect(Left,Top,Width+1,Height+1);
  BitBlt(PaintDC,0,0,Width,Height,MemDC,0,0,SRCCOPY);


  SelectObject(MemDC,OldBMP);
  DeleteDC(MemDC);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

//

Unit Description UnitIndex Master Index

procedure TGradient.CreateGradient;
var
   DC,MemDC : hDC;
   OldBMP : hBitmap;
   Brush : THandle;
   i,j : integer;
   R : TRect;
   XInc,YInc : single;
   C,C1 : TColorRef;
   RStart,GStart,BStart,RDelta,GDelta,BDelta,
   XOfs,YOfs : double;
   REnd,BEnd,GEnd,R1,G1,B1 : integer;
   CX,CY,GradSz,XNew,YNew:integer;
   GradSzMinus1: integer;
   Temp : string[20];
begin
  ProcName  := 'TGradient.CreateGradient'; Try
   G1 := 0; B1 := 0; GradSz := 0; XInc := 0; YInc := 0; R1 := 0;
   if fGradBMP <> 0 then DeleteObject(fGradBMP);
   fGradWidth := Width;
   fGradHeight := Height;
   if (fGradWidth=0) or (fGradHeight=0) then exit;
   DC := GetDC(0);
   MemDC := CreateCompatibleDC(DC);
   fGradBMP := CreateCompatibleBitmap(DC,fGradWidth,fGradHeight);
   OldBMP := SelectObject(MemDC,fGradBMP);

   case fGradientDirection of
     gdTopToBottom:
         GradSz := fGradHeight;
     gdLeftToRight:
         GradSz := fGradWidth;
     gdInsideOut,
     gdStretchInsideOut:
         begin
         if fGradWidth > fGradHeight then
            begin
            GradSz := fGradWidth;
            XInc := 1;
            if fGradientDirection = gdStretchInsideOut then
               YInc := (fGradHeight / fGradWidth)
            else
               YInc := 1;
            end
         else
            begin
            GradSz := fGradHeight;
            YInc := 1;
            if fGradientDirection = gdStretchInsideOut then
               XInc := (fGradWidth / fGradHeight)
            else
               XInc := 1;
            end;
         CX := fGradWidth shr 1;
         CY := fGradHeight shr 1;
         end;
   end;
   {}
   if fGradientDirection in [gdInsideOut,gdStretchInsideOut] then
      begin
      REnd := GetRValue(fEndingColor);
      GEnd := GetGValue(fEndingColor);
      BEnd := GetBValue(fEndingColor);
      RStart := GetRValue(fStartingColor);
      GStart := GetGValue(fStartingColor);
      BStart := GetBValue(fStartingColor);
      RDelta :=
       (REnd-RStart)/((GradSz) div 2);
      GDelta :=
       (GEnd-GStart)/((GradSz) div 2);
      BDelta :=
       (BEnd-BStart)/((GradSz) div 2);
      C := fStartingColor;
      XOfs := 0;
      YOfs := 0;
      XNew := 0;
      YNew := 0;
      With R do begin
        Left := CX; Top := CY;
        Right := CX+1; Bottom := CY+1;
        end;
      While (R.Left >=0) or (R.Top>=0) do
         begin
         Brush := CreateSolidBrush(C);
         FrameRect(MemDC,R,Brush);
         DeleteObject(Brush);
         XOfs := XOfs+XInc;
         YOfs := YOfs+YInc;
         if (XOfs-XNew) >= 1 then
             begin
             InflateRect(R,1,0);
             Inc(XNew);
             end;
         if (YOfs-YNew) >= 1 then
             begin
             InflateRect(R,0,1);
             Inc(YNew);
             end;
         if R1<>REnd then RStart := RStart+RDelta;
         if G1<>GEnd then GStart := GStart+GDelta;
         if B1<>BEnd then BStart := BStart+BDelta;
         R1 := Round(RStart);
         G1 := Round(GStart);
         B1 := Round(BStart);
         C := RGB(R1,G1,B1);
         end;
      end
   else
      begin
      GradSzMinus1 := GradSz-1;
      RDelta := (Integer(GetRValue(fEndingColor))-GetRValue(fStartingColor)) / GradSzMinus1;
      GDelta := (Integer(GetGValue(fEndingColor))-GetGValue(fStartingColor)) / GradSzMinus1;
      BDelta := (Integer(GetBValue(fEndingColor))-GetBValue(fStartingColor)) / GradSzMinus1;
      C := fStartingColor;
      C1 := C;
      i := 0;
      While i <= GradSzMinus1 do
         begin
         Brush := CreateSolidBrush(C);
         case fGradientDirection of
         gdTopToBottom:
            begin
            With R do
              begin Left := 0; Right := Width; Top := i; Bottom := i+1; end;
            end;
         gdLeftToRight:
            begin
            With R do
              begin Left := i; Right := i+1; Top := 0; Bottom := Height; end;
            end;
         end;
         FrameRect(MemDC,R,Brush);
         DeleteObject(Brush);
         Inc(i);
         C := RGB(Trunc(GetRValue(C1)+RDelta*(i-1)),Trunc(GetGValue(C1)+GDelta*(i-1)),Trunc(GetBValue(C1)+BDelta*(i-1)));
         end;
      end;
   SelectObject(MemDC,OldBMP);
   DeleteDC(MemDC);
   ReleaseDC(0,DC);
  Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;

end.
//