WEB开发网
开发学院软件开发Delphi 用DELPHI实现特色按钮 阅读

用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.

耿百强。

Tags:DELPHI 实现 特色

编辑录入:爽爽 [复制链接] [打 印]
赞助商链接