每当用到DELPHI自带的控件都感到少了一点什么，形状也好，颜色也好，变化的方式也好，都与自已的项目所需要的标准相差了一些，查阅了一些书籍后发现下面的控件很有可用之处！！！

以下是它的源代码：

unit DsFancyButton;

interface

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

type
  TTextStyle = (txNone, txLowered, txRaised, txShadowed);
  TShape = (shCapsule, shOval, shRectangle, shRoundRect);
  TDsFancyButton = class(TGraphicControl)
  private
    FButtonColor: TColor;
    FIsDown: Boolean;
    FFrameColor: TColor;
    FFrameWidth: Integer;
    FCornerRadius: Integer;
    FRgn, MRgn: HRgn;
    FShape: TShape;
    FTextColor: TColor;
    FTextStyle: TTextStyle;

    procedure SetButtonColor(Value: TColor);
    procedure CMEnabledChanged(var message: TMessage);
              message CM_ENABLEDCHANGED;
    procedure CMTextChanged(var message: TMessage);
              message CM_TEXTCHANGED;
    procedure CMDialogChar(var message: TCMDialogChar);
              message CM_DIALOGCHAR;
    procedure WMSize(var message: TWMSize); message WM_PAINT;
  protected
    procedure Click; override;
    procedure DrawShape;
    procedure Paint; override;
    procedure SetFrameColor(Value: TColor);
    procedure SetFrameWidth(Value: Integer);
    procedure SetCornerRadius(Value: Integer);
    procedure SetShape(Value: TShape);
    procedure SetTextStyle(Value: TTextStyle);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WriteCaption;
  public
    constructor Create(Aowner: TComponent); override;
    destructor Destroy; override;
  published
    property ButtonColor: TColor
             read FButtonColor write SetButtonColor;
    property Caption;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property FrameColor: TColor
             read FFrameColor write SetFrameColor;
    property FrameWidth: Integer
             read FFrameWidth write SetFrameWidth;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property CornerRadius: Integer
             read FCornerRadius write SetCornerRadius;
    property Shape: TShape
             read FShape write SetShape default shRoundRect;
    property ShowHint;
    property TextStyle: TTextStyle
             read FTextStyle write SetTExtStyle;
    property Visible;

    property OnClick;   property OnDragDrop;
    property OnDragOver;  property OnEndDrag;
    property OnMouseDown; Property OnMouseUp;
    Property OnMouseMove;
  end;

procedure Register;

implementation

constructor TDsFancyButton.Create(AOwner: TComponent);
begin
  inherited Create(Aowner);
  ControlStyle := [csClickEvents,  csCaptureMouse,  csSetCaption];
  Enabled := True;
  FButtonColor := clBtnFace;
  FIsDown := False;
  FFrameColor := clGray;
  FFrameWidth := 6;
  FCornerRadius := 10;
  FRgn := 0;
  FShape := shRoundRect;
  FTextStyle := txRaised;
  Height := 25;
  Visible := True;
  Width := 97;
end;

destructor TDsFancyButton.Destroy;
begin
  DeleteObject(FRgn);
  DeleteObject(MRgn);
  inherited Destroy;
end;

procedure TDsFancyButton.Paint;
var Dia: integer;
    ClrUp,  ClrDown: TColor;
begin
  Canvas.Brush.Style := bsClear;

  if FIsDown then
    begin ClrUp := clBtnShadow; ClrDown := clBtnHighlight; end
  else
    begin ClrUp := clBtnHighlight; ClrDown := clBtnShadow; end;

  with Canvas do
    begin
      case Shape of
        shRoundRect:
          begin
            Dia := 2*CornerRadius;
            Mrgn := CreateRoundRectRgn(0, 0, Width, Height, Dia, Dia);
          end;
        shCapsule:
          begin
            if Width < Height then Dia := Width else Dia := Height;
            Mrgn := CreateRoundRectRgn(0, 0, Width ,  Height, Dia, Dia);
          end;
        shRectangle: MRgn := CreateRectRgn(0, 0, Width - 1, Height - 1);
        shOval: MRgn := CreateEllipticRgn(0, 0, Width, Height);
      end;//case
      Canvas.Brush.Color := FButtonColor;
      FillRgn(Handle, MRgn, Brush.Handle);
      Brush.Color :=ClrUp;
      FrameRgn(Handle, MRgn, Brush.Handle, 1,1);
      OffsetRgn(MRgn, 1, 1);
      Brush.Color := ClrDown;
      FrameRgn(Handle, MRgn, Brush.Handle, 1, 1);
    end;//canvas
    DrawShape;
    WriteCaption;
end;

procedure TDsFancyButton.DrawShape;
var
  FC, Warna: TColor;
  R, G, B: Byte;
  AwalR, AwalG, AwalB, AkhirR, AkhirG, AkhirB, n, t, Dia: Integer;
begin
  if FFrameWidth mod 2=0 then t := FFrameWidth
  else t := FFrameWidth + 1;

  Warna := ColorToRGB(ButtonColor);
  FC := ColorToRGB(FrameColor);
  Canvas.Brush.Color := Warna;

  AwalR := GetRValue(FC); AkhirR := GetRValue(Warna);
  AwalG := GetGValue(FC); AkhirG := GetGValue(Warna);
  AwalB := GetBValue(FC); AkhirB := GetBValue(Warna);
  FRgn := 0;
  with Canvas do
  for n := 0 to t - 1 do
  begin
    R := AwalR + Trunc(Sqrt(t*t - Sqr(t-n))*(AkhirR - AwalR)/t);
    G := AwalG + Trunc(Sqrt(t*t - Sqr(t-n))*(AkhirG - AwalG)/t);
    B := AwalB + Trunc(Sqrt(t*t - Sqr(t-n))*(AkhirB - AwalB)/t);
    Brush.Color := RGB(R, G, B);

    Case Shape of
      shOval: FRgn := CreateEllipticRgn(1 + n, 1 + n, Width - n, Height - n);
      shRoundRect:
        begin
          Dia := CornerRadius;
          if (Dia - n) >0 then
            FRgn :=
              CreateRoundRectRgn(1 + n, 1 + n ,Width - n, Height - n, 2*(Dia - n), 2*(Dia - n))
          else FRgn := CreateRectRgn( 1 + n, 1 + n, Width - n - 1, Height - n - 1);
        end;
       shCapsule:
         begin
           if Width < Height then Dia := Width div 2 else Dia := Height div 2;
             if (Dia - n) > 0 then
               FRgn:=
                 CreateRoundRectRgn(1 + n, 1 + n, Width - n, Height - n, 2*(Dia - n), 2*(Dia - n))
             else FRgn := CreateRectRgn(1 + n, 1 + n ,Width - n - 1, Height - n - 1);

[1] [2]  下一页