delphi 水晶按钮

2019独角兽企业重金招聘Python工程师标准>>>

unit CrystalButton;

interface

uses
  SysUtils, Classes, Windows, Messages, Graphics, Controls, StdCtrls, Forms;
type
  PTriVertex = ^TTriVertex;
  TTriVertex = packed record
    x: Longint;
    y: Longint;
    Red: Word;
    Green: Word;
    Blue: Word;
    Alpha: Word;
  end;

  TFillDir = (fdHorizontal, fdVertical);
type
  TCrystalButton = class(TGraphicControl)
  private
    FMouseOver: Boolean;
    FDown: Boolean;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;

    procedure GetRGB(C: TColor; out R, G, B: Integer);
    procedure SolidGradient(DC: HDC; Rect: TRect; Color1, Color2,Color3: TColor; Dir: TFillDir = fdVertical); overload;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Click; override;
  published
    property Caption;
    property Enabled;
    property Font;
    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Height;
    property Width;
    property Left;
    property Top;
    property Name;
    property Visible;
    property Cursor;
  end;

procedure Register;

implementation

//uses uGradientFill;
function GradientFillEx(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG; Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; external msimg32 name 'GradientFill';
//function GradientFillEx;
procedure ods(const str: string);
begin
  OutputDebugString(PChar(str));
end;

{ TButtonEx }

procedure TCrystalButton.Click;
begin
  inherited Click;
end;

procedure TCrystalButton.CMMouseEnter(var Message: TMessage);
begin
  FMouseOver := True;
  Repaint;
  if Parent <> nil then
    Parent.Perform(CM_MOUSEENTER, 0, Longint(Self));
end;

procedure TCrystalButton.CMMouseLeave(var Message: TMessage);
begin
  FMouseOver := False;
  if FDown then
    FDown := False;
  Repaint;
  if Parent <> nil then
    Parent.Perform(CM_MOUSELEAVE, 0, Longint(Self));
end;

constructor TCrystalButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csDoubleClicks];
  ParentFont := True;
end;

procedure TCrystalButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FDown := True;
      repaint;
    end;
  end;
end;

procedure TCrystalButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  pt: TPoint;
  Rect: TRect;
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDown then
  begin
    pt.X := X;
    pt.Y := Y;
    Rect := ClientRect;
    DoClick := PtInRect(Rect, pt);
    if DoClick then
    begin
      FDown := False;
      repaint;
    end;
    if DoClick then Click;
  end;
end;

procedure TCrystalButton.Paint;
var
  Rect: TRect;
  clr1, clr2,clr3: TColor;
begin
  Rect := ClientRect;
  Canvas.Brush.Style := bsClear;
  Canvas.Pen.Color := RGB(85, 148, 22);
  Canvas.RoundRect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, 6, 6);

  if FDown then
  begin
      InflateRect(Rect, -1, -1);
      clr3 := RGB($ef,$9a, $90);
      clr2 := RGB($ff,$ff, $ff );
      clr1 := RGB($ef,$9a, $90);
      SolidGradient(Canvas.Handle, Rect, clr1, clr2,clr3);
  end
  else
  begin
    if FMouseOver then
    begin

      InflateRect(Rect, -1, -1);
      clr3 := RGB($66, $cc,$99);
      clr2 := RGB($66, $cc,$99);
      clr1 := RGB($ff,$ff, $ff );
      SolidGradient(Canvas.Handle, Rect, clr1, clr2,clr3);
    end
    else
    begin
      InflateRect(Rect, -1, -1);
      clr3 := RGB($33, $cc,$99);
      clr2 := RGB($33, $cc,$99);
      clr1 := RGB($ff,$ff, $ff);
      SolidGradient(Canvas.Handle, Rect, clr1, clr2,clr3);
    end
  end;

 // Canvas.Font.Color := clBlack;//clWhite;
 // Canvas.Font.Style := [fsBold];
  Canvas.Font:=self.Font;
  DrawText(Canvas.Handle, PChar(Caption), -1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
end;

procedure TCrystalButton.GetRGB(C: TColor; out R, G, B: Integer);
begin
  if Integer(C) < 0 then C := GetSysColor(C and $000000FF);
  R := C and $FF;
  G := C shr 8 and $FF;
  B := C shr 16 and $FF;
end;

procedure TCrystalButton.SolidGradient(DC: HDC; Rect: TRect; Color1, Color2,Color3: TColor; Dir: TFillDir = fdVertical);
var
  vert: array[0..3] of TTriVertex;
  gRect:array[0..1] of TGradientRect;
  nMode: Cardinal;
begin
  vert[0].x := Rect.Left;
  vert[0].y := Rect.Top;
  vert[0].Red := GetRValue(Color1) shl 8;
  vert[0].Green := GetGValue(Color1) shl 8;
  vert[0].Blue := GetBValue(Color1) shl 8;
  vert[0].Alpha := 0;

  vert[1].x := Rect.Right;
  vert[1].y := Rect.Bottom div 2;
  vert[1].Red := GetRValue(Color2) shl 8;
  vert[1].Green := GetGValue(Color2) shl 8;
  vert[1].Blue := GetBValue(Color2) shl 8;
  vert[1].Alpha := 0;
  
  vert[2].x := Rect.Left;
  vert[2].y := Rect.Bottom div 2;
  vert[2].Red := GetRValue(Color2) shl 8;
  vert[2].Green := GetGValue(Color2) shl 8;
  vert[2].Blue := GetBValue(Color2) shl 8;
  vert[2].Alpha := 0; 
  
  vert[3].x := Rect.Right;//Right;
  vert[3].y := Rect.Bottom;
  vert[3].Red := GetRValue(Color3) shl 8;
  vert[3].Green := GetGValue(Color3) shl 8;
  vert[3].Blue := GetBValue(Color3) shl 8;
  vert[3].Alpha := 0;

  gRect[0].UpperLeft := 0;
  gRect[0].LowerRight := 1;
  gRect[1].UpperLeft := 2;
  gRect[1].LowerRight := 3;
  if Dir = fdVertical then
    nMode := GRADIENT_FILL_RECT_V
  else
    nMode := GRADIENT_FILL_RECT_H;
    
  GradientFillEx(DC, @vert, 4, @gRect, 2, nMode);
end;
procedure Register;
begin
  RegisterComponents('Samples', [TCrystalButton]);
end;

end.
 

显示效果如下

 

转载于:https://my.oschina.net/jingshishengxu/blog/684158