特色按钮

原创 2001年07月13日 09:15:00
 

每当用到DELPHI自带的控件都感到少了一点什么,形状也好,颜色也好,变化的方式也好,都与自已的项目所需要的标准相差了一些,查阅了一些书籍后发现下面的控件很有可用之处!!!<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" />

以下是它的源代码:

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.

创建特色按钮

建一个 按钮:CButton myButton;myButton.Create(_T("My button"), WS_CHILD|WS_VISIBLE|BS_PUSHBUTTON, CRect(10...
  • sichuanpb
  • sichuanpb
  • 2013年08月30日 16:44
  • 496

wordpress文章特色图片功能详解

wordpress文章特色图片功能详解 可是很多朋友会问:我的后台怎么没有这个选项呢?因为该主题不支持,没关系,下面就开始让你的博客和wordpress特色图片一起炫起来吧。 ...
  • dengwenquan2011
  • dengwenquan2011
  • 2011年10月11日 22:04
  • 1355

OpenCart之特色商品(Featured)模块教程

本教程由opencart中国网站制作,如有转载请注明出处:http://www.opencartchina.com/bbs/topic1015.html。 如果在使用opencart过程中有什么问题或...
  • OpenCartChina
  • OpenCartChina
  • 2013年12月19日 10:10
  • 1551

用DELPHI实现特色按钮

每当用到DELPHI自带的控件都感到少了一点什么,形状也好,颜色也好,变化的方式也好,都与自已的项目所需要的标准相差了一些,查阅了一些书籍后发现下面的控件很有可用之处!!!以下是它的源代码:unit ...
  • dajianshi
  • dajianshi
  • 2001年07月25日 17:01
  • 1155

打造有企业特色的ERP

作者:冯强 2003.11.07  中国企业上线ERP的成功率是不高的,前几年有种极端的说法--失败率100%。现在看来,这种言论有点夸张,但成功率不高,确是不争的事实。一般的标准,是以能否成功上线,...
  • Jhzyz
  • Jhzyz
  • 2006年02月15日 21:07
  • 2846

我为癖好狂――特色个人网站推荐

 癖好是一个非常中性的词,词典对它的解释是“对某种事物的特别爱好”。癖好是装不出来的,它是一种真性情的流露,只有那种专注、执著的爱,才可以称之为癖好。过去人们的癖好只能敝帚自珍,最多与身边的三五同好一...
  • unimoon
  • unimoon
  • 2006年08月24日 12:58
  • 5448

wordpress 特色图片去掉width宽度 直接调用src 缩略图自适应响应式

把下面的代码放在functions.php中即可去掉img中的width和height属性,从而可以在css中自定义图片宽高. // 自适应图片删除width和height,by Ludou add_...
  • viqecel
  • viqecel
  • 2016年10月21日 11:07
  • 1178

窗口子类化实现自绘按钮如此简单

有没有发现利用createwindow创建按钮感觉太单调,msdn上说的owndraw 按钮太复杂,其实子类化按钮,可以很方便的实现自绘按钮,只需要会点贴图知识就行了。 下面采用gdi+贴图:(关于...
  • dai_jing
  • dai_jing
  • 2013年04月21日 23:06
  • 2988

Windows Server 2012新特性

数据中心操作系统   面对企业希望统筹管理多个数据中心的计算资源的需求,Windows Server 2012通过全面的PowerShell命令可帮助IT部门对更为广泛的管理任务实现自动化,并与Sy...
  • cong20089
  • cong20089
  • 2013年11月12日 10:52
  • 441

一文看懂亚马逊无人店背后的技术流程!

看点:亚马逊GO无人店开放了,从此西雅图人民逛超市只需要一分钟!亚马逊GO无人店于今日(1月22日)在美国西雅图开放,亚马逊在五年前就开始研究无人店技术,早在2016年12月,亚马逊GO对亚马逊西雅图...
  • e848lip6R
  • e848lip6R
  • 2018年01月22日 00:00
  • 8
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:特色按钮
举报原因:
原因补充:

(最多只允许输入30个字)