程序師世界是廣大編程愛好者互助、分享、學習的平台,程序師世界有你更精彩!
首頁
編程語言
C語言|JAVA編程
Python編程
網頁編程
ASP編程|PHP編程
JSP編程
數據庫知識
MYSQL數據庫|SqlServer數據庫
Oracle數據庫|DB2數據庫
 程式師世界 >> 編程語言 >> 更多編程語言 >> Delphi >> 用DELPHI實現特色按鈕

用DELPHI實現特色按鈕

編輯:Delphi
特色按鈕    

  每當用到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;

  1. 上一頁:
  2. 下一頁:
Copyright © 程式師世界 All Rights Reserved