用DELPHI实现特色按钮

　2006-02-04 13:31:25　来源：WEB开发网　　　

核心提示：特色按钮每当用到DELPHI自带的控件都感到少了一点什么，形状也好，用DELPHI实现特色按钮，颜色也好，变化的方式也好，都与自已的项目所需要的标准相差了一些，查阅了一些书籍后发现下面的控件很有可用之处！！！以下是它的源代码：unit DsFancyButton;interfaceuses SysUtils,Win

特色按钮　　

每当用到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);
　　　　 end;
　　　 else FRgn := CreateRectRgn(1 + n, 1 + n, Width - n - 1,

Height - n - 1);
　 end;//case
　 FrameRgn(Handle, FRgn, Brush.Handle, 1, 1);
end;
end;

procedure TDsFancyButton.WriteCaption;
var
Flags: Word;
BtnL, BtnT, BtnR, BtnB: Integer;
R, TR: TRect;
begin
R := ClientREct; TR := ClientRect;
Canvas.Font := Self.Font;
Canvas.Brush.Style := bsClear;
Flags := DT_CENTER or DT_SINGLELINE;
Canvas.Font := Font;

if FIsDown then FTextColor := FrameColor
else FTextColor := Self.Font.Color;

with canvas do
　 begin
　　 BtnT := (Height - TextHeight(Caption)) div 2;
　　 BtnB := BtnT + TextHeight(Caption);
　　 BtnL := (Width - TextWidth(Caption)) div 2;
　　 BtnR := BtnL + TextWidth(Caption);
　　 TR := Rect(BtnL, BtnT, BtnR, BtnB);
　　 R := TR;
　　 if ((TextStyle = txLowered) and FIsDown ) or
　　　　 ((TextStyle = txRaised) and not FIsDown) then
　　 begin
　　　 Font.Color := clBtnHighLight;
　　　 OffsetRect(TR, -1 + 1, -1 + 1);
　　　 DrawText(Handle, PChar(Caption), Length(Caption), TR,

Flags);
　　 end
　　 else if ((TextStyle = txLowered) and not FIsDown) or
　　　　　　 ((TextStyle = txRaised) and FIsDown) then
　　　　　 begin
　　　　　　 Font.Color := clBtnHighLight;
　　　　　　 OffsetRect(TR, + 2, + 2);
　　　　　　 DrawText(Handle, PChar(Caption), Length(Caption), TR,

Flags);
　　　　　 end
　　　　　 else if (TextStyle = txShadowed) and FIsDown then
　　　　　　　 begin
　　　　　　　　 Font.Color := clBtnShadow;
　　　　　　　　 OffsetREct(TR, 3 + 1, 3 + 1);
　　　　　　　　 DrawText(Handle, PChar(Caption),

Length(Caption), TR, Flags);
　　　　　　　 end
　　　　　　　 else if (TextStyle = txShadowed) and not FIsDown

then
　　　　　　　 begin
　　　　　　　　 Font.Color := clBtnShadow;
　　　　　　　　 OffsetRect(TR, 2 + 1, 2 + 1);
　　　　　　　　 DrawText(Handle, PChar(Caption),

Length(Caption), TR, Flags);
　　　　　　　 end;

if Enabled then Font.Color := FTextColor//self.Font.Color
　　 else if (TextStyle = txShadowed) and not Enabled then
　　　 Font.Color := clBtnFace
　　 else Font.Color := clBtnShadow;
　　 if FIsDown then OffsetRect(R, 1, 1)
　　 else OffsetRect(R, -1, -1);
　　 DrawText(Handle, PChar(Caption), Length(Caption), R, Flags);
　 end;
end;

procedure TDsFancyButton.SetButtonColor(value: TColor);
begin
if value <> FButtonColor then
　 begin FButtonColor := value ; Invalidate; end;
end;

procedure TDsFancyButton.WMLButtonDown(var message:

TWMLButtonDown);
begin
if not PtInRegion(MRgn, message.xPos, message.yPos) then Exit;
FIsDown := True;
Paint;
inherited;
end;

procedure TDsFancyButton.WMLButtonUp(var message: TWMLButtonUp);
begin
if not FIsDown then Exit;
FIsDown := False;
paint;
inherited;
end;

procedure TDsFancyButton.SetShape(value: TShape);
begin
if value <> FShape then
　 begin FShape := value; Invalidate; end;
end;

procedure TDsFancyButton.SetTextStyle(value: TTextStyle);
begin
if value<>FTextStyle then
　 begin FTextStyle := value; Invalidate; end;
end;

procedure TDsFancyButton.SetFrameColor(value: TColor);
begin
if Value<>FFrameColor then
　 begin FFrameColor := Value; Invalidate;end;
end;

procedure TDsFancyButton.SetFrameWidth(Value: Integer);
var
w: integer;
begin
if Width<height then w := Width else w := Height;
if Value<>FFrameWidth then FFrameWidth := value;
if FFrameWidth < 4 then FFrameWidth := 4;
if FFrameWidth >(w div 2) then FFrameWidth := (w div 2);
Invalidate;
end;

procedure TDsFancyButton.SetCornerRadius(Value: integer);
var
w: integer;
begin
if Width<Height then w := Width else w := Height;
if value<>FCornerRadius then FCornerRadius := value;
if FCornerRadius<3 then FCornerRadius := 3;
if FCornerRadius>w then FCornerRadius := w;
Invalidate;
end;

procedure TDsFancyButton.CMEnabledChanged(var message: Tmessage);
begin
inherited;
invalidate;
end;

procedure TDsFancyButton.CMTextChanged(var message: TMessage);
begin
Invalidate;
end;

procedure TDsFancyButton.CMDialogChar(var message:TCMDialogChar);
begin
With Message do
　 if IsAccel (CharCode, Caption) and Enabled then
　　 begin Click; Result := 1 ;end
　 else inherited;
end;

procedure TDsFancyButton.WMSize(var Message: TWMSize);
begin
inherited;
if width>300 then width := 300;
if Height>300 then Height := 300;
end;

procedure TDsFancyButton.Click;
begin
FIsDown := False;
Invalidate;
inherited Click;
end;

procedure Register;
begin
RegisterComponents('WYM COMPONENT',[TDsFancyButton]);
end;

end.

耿百强。