gradecolorimage.pas

机房管理系统 是用VB设计的简单的管理系统

unit GradeColorImage;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls,Graphics;

type
  TGradientFillType=(rgsHorizontal, rgsVertical, rgsElliptic, rgsRectangle, rgsVerticalCenter,
        rgsHorizontalCenter, rgsNWSE, rgsNWSW, rgsSENW,rgsSWNE, rgsSweet, rgsStrange, rgsNeo);

const crDefaultWidth=24;
const crDefaultHeight=24;
const crDefaultFromColor=clRed;
const crDefaultToColor=clWhite;
const crDefaultFillType=rgsElliptic;

type
  TGCImg = class(TGraphicControl)
  private
    { Private declarations }
    bmp:TBitmap;
    r:TRect;
    InMousePress:boolean;
    FFromColor,FToColor:TColor;
    FGradientFillType:TGradientFillType;
    fOnClick, fOnDblClick: TNotifyEvent;
    fOnMouseDown, fOnMouseUp: TMouseEvent;
    fOnMouseMove: TMouseMoveEvent;
    procedure SetFromColor(value: TColor);
    procedure SetToColor(value: TColor);
    procedure SetGradientFillType(value: TGradientFillType);
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,Y: Integer); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    // 属性
    property Action;
    property Align;
    property Enabled;
    property FromColor:TColor read FFromColor write SetFromColor;
    property GradientFillType:TGradientFillType read FGradientFillType write SetGradientFillType;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property ToColor:TColor read FToColor write SetToColor;
    property Visible;
    // 方法
    property OnClick: TNotifyEvent read fOnClick write fOnClick;
    property OnDblClick: TNotifyEvent read fOnDblClick write fOnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    {$IFNDEF VER80}
    property OnStartDrag;
    {$ENDIF}
    property OnMouseDown: TMouseEvent read fOnMouseDown write fOnMouseDown;
    property OnMouseMove: TMouseMoveEvent read fOnMouseMove write fOnMouseMove;
    property OnMouseUp: TMouseEvent read fOnMouseUp write fOnMouseUp;
  end;

procedure Register;
procedure RbsGradientFill(Canvas: TCanvas; grdType: TGradientFillType;
  fromCol, toCol: TColor; ARect: TRect);

implementation

procedure Register;
begin
  RegisterComponents('Wuqiu', [TGCImg]);
end;

constructor TGCImg.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  width:=crDefaultWidth;
  Height:=crDefaultHeight;
  r:=Rect(0,0,width,Height);
  FFromColor:=crDefaultFromColor;
  FToColor:=crDefaultToColor;
  FGradientFillType:=crDefaultFillType;
  bmp:=TBitmap.Create;
  bmp.Width :=width;
  bmp.Height :=Height;
  InMousePress:=false;
  if bmp<>nil then
    RbsGradientFill(bmp.Canvas,FGradientFillType,FFromColor,FToColor,r);

end;

destructor TGCImg.Destroy;
begin
  inherited Destroy;
  bmp.Free;
end;

procedure TGCImg.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Enabled then
  begin
    if Assigned(fOnMouseDown) then
      fOnMouseDown(Self, Button, Shift, X, Y);
    if (Button = mbLeft) then
    begin
      InMousePress := True;
      if (ssDouble in Shift) and Assigned(fOnDblClick) then
        fOnDblClick(Self);
    end;
  end;

end;

procedure TGCImg.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(fOnMouseMove) then
    fOnMouseMove(Self, Shift, X, Y);
end;

procedure TGCImg.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if InMousePress then
  begin
    InMousePress := False;
    if (X>=0)and(X<=Width)and(Y>0)and(Y<=Height) then
      if Assigned(fOnClick) then
        fOnClick(Self);
  end;
  if Assigned(fOnMouseUp) then
    fOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TGCImg.Paint;
begin
  if bmp<>nil then
    Canvas.CopyRect(r, bmp.Canvas, r);
end;

procedure TGCImg.SetBounds(aLeft, aTop, aWidth,
  aHeight: Integer);
begin
  inherited SetBounds(aLeft, aTop, aWidth, aHeight);
  if (width<>r.Right)or(Height<>r.Bottom) then
  begin
    if bmp<>nil then
    begin
      r:=Rect(0,0,Width,Height);
      bmp.Width :=width;
      bmp.Height :=height;
      RbsGradientFill(bmp.Canvas,FGradientFillType,FFromColor,FToColor,r);
      Invalidate;
    end;
  end;
end;

procedure TGCImg.SetFromColor(value: TColor);
begin
  if FFromColor<>value then
  begin
    FFromColor:=value;
    if bmp<>nil then
    begin
      RbsGradientFill(bmp.Canvas,FGradientFillType,FFromColor,FToColor,r);
      Invalidate;
    end;
  end;
end;

procedure TGCImg.SetGradientFillType(value: TGradientFillType);
begin
  if FGradientFillType<>value then
  begin
    FGradientFillType:=value;
    if bmp<>nil then
    begin
      RbsGradientFill(bmp.Canvas,FGradientFillType,FFromColor,FToColor,r);
      Invalidate;
    end;
  end;
end;

procedure TGCImg.SetToColor(value: TColor);
begin
  if FToColor<>value then
  begin
    FToColor:=value;
    if bmp<>nil then
    begin
      RbsGradientFill(bmp.Canvas,FGradientFillType,FFromColor,FToColor,r);
      Invalidate;
    end;
  end;
end;

procedure RbsGradientFill(Canvas: TCanvas; grdType: TGradientFillType;
  fromCol, toCol: TColor; ARect: TRect);
var
  FromR, FromG, FromB : Integer;
  DiffR, DiffG, DiffB : Integer;

  i: integer;
  bm:TBitmap;
  ColorRect:TRect;
  R,G,B:Byte;

  //for elliptical
  Pw, Ph : Real;
  x0,y0,x1,y1,x2,y2,x3,y3 : Real;
  points:array[0..3] of TPoint;
  haf:Integer;

begin
  //set bitmap
  bm:=TBitmap.Create;
  bm.Width := ARect.Right;
  bm.Height := ARect.Bottom;

  //calc colors
  FromR := fromcol and $000000ff;  //Strip out separate RGB values
  FromG := (fromcol shr 8) and $000000ff;
  FromB := (fromcol shr 16) and $000000ff;
  DiffR := (tocol and $000000ff) - FromR;   //Find the difference
  DiffG := ((tocol shr 8) and $000000ff) - FromG;
  DiffB := ((tocol shr 16) and $000000ff) - FromB;

  //draw gradient
  case grdType of
  rgsHorizontal:
     begin
     ColorRect.Top:= 0;                //Set rectangle top
     ColorRect.Bottom := bm.Height;
     for I := 0 to 255 do begin         //Make lines (rectangles) of color
      ColorRect.Left:= MulDiv (I, bm.Width, 256);    //Find left for this color
      ColorRect.Right:= MulDiv (I + 1, bm.Width, 256);   //Find Right
      R := fromR + MulDiv(I, diffr, 255);    //Find the RGB values
      G := fromG + MulDiv(I, diffg, 255);
      B := fromB + MulDiv(I, diffb, 255);
      bm.Canvas.Brush.Color := RGB(R, G, B);   //Plug colors into brush
      bm.Canvas.FillRect(ColorRect);           //Draw on Bitmap
     end;

     end;
  rgsVertical:
     begin
     ColorRect.Left:= 0;                //Set rectangle left&right
     ColorRect.Right:= bm.Width;
     for I := 0 to 255 do begin         //Make lines (rectangles) of color
      ColorRect.Top:= MulDiv (I, bm.Height, 256);    //Find top for this color
      ColorRect.Bottom:= MulDiv (I + 1, bm.Height, 256);   //Find Bottom
      R := fromr + MulDiv(I, diffr, 255);    //Find the RGB values
      G := fromg + MulDiv(I, diffg, 255);
      B := fromb + MulDiv(I, diffb, 255);
      bm.Canvas.Brush.Color := RGB(R, G, B);   //Plug colors into brush
      bm.Canvas.FillRect(ColorRect);           //Draw on Bitmap
    end;

     end;
  rgsElliptic:
     begin
     bm.Canvas.Pen.Style := psClear;
     bm.Canvas.Pen.Mode := pmCopy;
     x1 := 0 - (bm.Width / 4);
     x2 := bm.Width + (bm.Width / 4)+4;
     y1 := 0 - (bm.Height / 4);
     y2 := bm.Height + (bm.Height / 4)+4;
     Pw := ((bm.Width / 4) + (bm.Width / 2)) / 155;
     Ph := ((bm.Height / 4) + (bm.Height / 2)) / 155;
     for I := 0 to 155 do begin         //Make ellipses of color
      x1 := x1 + Pw;
      x2 := X2 - Pw;
      y1 := y1 + Ph;
      y2 := y2 - Ph;
      R := fromr + MulDiv(I, diffr, 155);    //Find the RGB values
      G := fromg + MulDiv(I, diffg, 155);
      B := fromb + MulDiv(I, diffb, 155);
      bm.Canvas.Brush.Color := R or (G shl 8) or (b shl 16);   //Plug colors into brush
      bm.Canvas.Ellipse(Trunc(x1),Trunc(y1),Trunc(x2),Trunc(y2));
    end;
       end;
     
  rgsRectangle:
     begin
     bm.Canvas.Pen.Style := psClear;
     bm.Canvas.Pen.Mode := pmCopy;
     x1 := 0;
     x2 := bm.Width+2;
     y1 := 0;
     y2 := bm.Height+2;
     Pw := (bm.Width / 2) / 255;
     Ph := (bm.Height / 2) / 255;
     for I := 0 to 255 do begin         //Make rectangles of color
      x1 := x1 + Pw;
      x2 := X2 - Pw;
      y1 := y1 + Ph;
      y2 := y2 - Ph;
      R := fromr + MulDiv(I, diffr, 255);    //Find the RGB values
      G := fromg + MulDiv(I, diffg, 255);