特色按钮
每当用到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, FR [1] [2] 下一页 没有相关教程
|