xpbutton.pas

xpbutton是一個delphi的按鈕套件,可以更改字體的顏色及字型

{
 Copyright:      rhoStyle   
 mailto:	 [e-mail]
 Author:         rhoStyle developers group 
 Remarks:        freeware
 known Problems: none
 Version:        1.0
 Delphi Version: Delphi 3-7
 Description:    This is Windows XP style button. You can use it with 
		 Windows 95, 98, NT, ME, 2000 and XP

}

unit xpButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, XPGraphUtil;

type
  TxpButton = class(TCustomControl)
  private
    FCaption : TCaption;
    FActive  : Boolean;
    FDowned  : Boolean;
    FFont    : TFont;
    FFocused : Boolean;
    FModalResult : TModalResult;
    FHotKey  : Char;
    FCancel  : Boolean;
    FDefault : Boolean;

    FOnClick : TNotifyEvent;
    FOnEnter : TNotifyEvent;
    FOnExit  : TNotifyEvent;
    FOnKeyDown : TKeyEvent;
    FOnKeyUp : TKeyEvent;

    procedure SetCaption (ACaption : TCaption);
    function  GetCaption : TCaption;

    procedure SetDowned (ADowned : Boolean);
    function  GetDowned : Boolean;

    procedure SetFont (AFont : TFont);
    function  GetFont : TFont;

    procedure SetModalResult (AModalResult : TModalResult);
    function  GetModalResult : TModalResult;

    procedure FOnButtonClick;
  protected
    procedure Paint; override;
    procedure MouseEnter (var Message : TMessage); message CM_MOUSEENTER;
    procedure MouseLeave (var Message : TMessage); message CM_MOUSELEAVE;
    procedure LMouseDown  (var Message : TMessage); message WM_LBUTTONDOWN;
    procedure RMouseDown  (var Message : TMessage); message WM_RBUTTONDOWN;
    procedure LMouseUp  (var Message : TMessage); message WM_LBUTTONUP;
    procedure RMouseUp  (var Message : TMessage); message WM_RBUTTONUP;
    procedure LMouseDblClick  (var Message : TMessage); message WM_LBUTTONDBLCLK;
    procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
    procedure CMExit(var Message: TCMLostFocus); message CM_EXIT;
    procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
    procedure WMKeyDown(var Message: TMessage); message WM_KEYDOWN;
    procedure WMKeyUp(var Message: TMessage); message WM_KEYUP;
    procedure CMDialogChar(var Message : TCMDialogChar);  message CM_DIALOGCHAR;
    procedure CMDialogKey(var Message : TCMDialogKey);  message CM_DIALOGKEY;

  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property Caption : TCaption read GetCaption write SetCaption;
    property Font : TFont read GetFont write SetFont;
    property Enabled;
    property ParentFont;
    property Hint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Cancel : Boolean read FCancel write FCancel default False;
    property Default : Boolean read FDefault write FDefault default False;
    property ModalResult : TModalResult read GetModalResult write SetModalResult default mrNone;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
    property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
  end;

procedure Register;


implementation

constructor TxpButton.Create (AOwner : TComponent);
begin
  Inherited Create (AOwner);
  Width := 75;
  Height := 25;
  FFont := TFont.Create;
  FCaption := 'XP Button';
  Enabled := True;
  FActive := False;
  FDowned := False;
  FFocused := False;
  TabStop := true;
end;

destructor TxpButton.Destroy;
begin
  FFont.Free;
  inherited;
end;

procedure TxpButton.CMDialogKey(var Message : TCMDialogKey);
begin
  if Enabled and  ((FCancel and (Message.CharCode = VK_ESCAPE)) or
  (FDefault and (Message.CharCode = VK_RETURN))) then
    FOnButtonClick;
end;

procedure TxpButton.Paint;
var
  AText : String;
begin
  AText := FCaption;
  if Pos ('&', FCaption) <> 0 then Delete (AText, Pos ('&', AText), 1);

  if Enabled then
  begin
    Canvas.Pen.Width := 1;
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := RGB (214, 211, 211);
    Canvas.Pen.Color := RGB (214, 211, 211);
    Canvas.RoundRect (0, 0, Width, Height, 3, 3);

    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Color := RGB (0, 60, 116);
    Canvas.RoundRect (1, 1, Width-1, Height-1, 5, 5);

    if (FDowned) and FActive then
      GradientFillRect (Canvas, Rect (4, 4, Width-4, Height-4), RGB (253, 253, 253),
          RGB (205, 204, 223), fdBottomToTop, HeightOf (ClientRect) div 2)
    else
      GradientFillRect (Canvas, Rect (4, 4, Width-4, Height-4), RGB (253, 253, 253),
          RGB (205, 204, 223), fdTopToBottom, HeightOf (ClientRect) div 3);


    Canvas.Pen.Color := RGB (206, 231, 255);
    Canvas.MoveTo (3, 2);
    Canvas.LineTo (Width - 3, 2);

    Canvas.Pen.Color := RGB (105, 130, 238);
    Canvas.MoveTo (3, Height-3);
    Canvas.LineTo (Width - 3, Height-3);

    Canvas.Pen.Color := RGB (188, 212, 246);
    Canvas.Rectangle (2, 3, Width-2, Height-3);

    Canvas.Pen.Color := RGB (255, 255, 255);
    Canvas.MoveTo (3, 4);
    Canvas.LineTo (3, Height-4);

    Canvas.Pen.Color := RGB (255, 255, 255);
    Canvas.MoveTo (Width-4, 4);
    Canvas.LineTo (Width-4, Height-4);

    Canvas.Pen.Color := RGB (255, 255, 255);
    Canvas.MoveTo (3, Height-1);
    Canvas.LineTo (Width-3, Height-1);
    Canvas.MoveTo (Width-1, Height-4);
    Canvas.LineTo (Width-1, 2);

    if FActive then
    begin
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.Color := RGB (248, 179, 48);
      Canvas.Pen.Width := 1;
      Canvas.RoundRect (3, 3, Width-3, Height-3, 2, 2);
    end;

    Canvas.Font := FFont;
    Canvas.TextRect (Rect (4, 4, Width-4, Height-4),
      (Width - Canvas.TextWidth (AText)) div 2 + Integer (FDowned),
      (Height - Canvas.TextHeight (AText)) div 2 + Integer (FDowned), AText);

    if FFocused then
    begin
      Canvas.Brush.Style := bsSolid;
      Canvas.Pen.Color := clWhite;
      Canvas.Pen.Width := 2;
      Canvas.DrawFocusRect (Rect (4, 4, Width - 4, Height - 4));
    end;

  end
  else
  Begin // not Enabled
    Canvas.Brush.Color := RGB (241, 241, 237);
    Canvas.Pen.Color := RGB (214, 211, 211);
    Canvas.RoundRect (0, 0, Width, Height, 3, 3);
    Canvas.Pixels [0, 0] := clBtnFace;
    Canvas.Pixels [Width-1, 0] := clBtnFace;
    Canvas.Pixels [Width-1, Height-1] := clBtnFace;
    Canvas.Pixels [0, Height-1] := clBtnFace;

    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Color := RGB (196, 195, 191);
    Canvas.RoundRect (1, 1, Width-1, Height-1, 5, 5);

    Canvas.Font := FFont;
    Canvas.Font.Color := RGB (161, 161, 146);
    Canvas.TextRect (Rect (4, 4, Width-4, Height-4),
      (Width - Canvas.TextWidth (AText)) div 2,
      (Height - Canvas.TextHeight (AText)) div 2, AText);
  end;

  if Pos ('&', FCaption) <> 0 then
  begin
    Canvas.Pen.Color := Canvas.Font.Color;
    Canvas.Pen.Width := 1;
    Canvas.MoveTo (((Width - Canvas.TextWidth (AText)) div 2) + Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption)-1)) + Integer (FDowned),
                   ((Height - Canvas.TextHeight (AText)) div 2) + Canvas.TextHeight (AText) + Integer (FDowned));
    Canvas.LineTo (((Width - Canvas.TextWidth (AText)) div 2) + Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption))) + Integer (FDowned),
                   ((Height - Canvas.TextHeight (AText)) div 2) + Canvas.TextHeight (AText) + Integer (FDowned));
  end;

end;

procedure TxpButton.MouseEnter (var Message : TMessage);
begin
  if FActive then Exit;
  FActive := true;
  Repaint;
end;

procedure TxpButton.MouseLeave (var Message : TMessage);
begin
  if FActive then
  begin
    FActive := False;
    Repaint;
  end;
end;


procedure TxpButton.SetCaption (ACaption : TCaption);
begin
  if FCaption <> ACaption then
  Begin
    FCaption := ACaption;
    if (Pos ('&', FCaption) <> 0) and (Pos ('&', FCaption) < Length (FCaption)) then
      FHotKey := UpperCase (String (Copy (FCaption, Pos ('&', FCaption)+1, 1)))[1]
    else
      FHotKey := #0;
    Repaint;
  end;
end;

function  TxpButton.GetCaption : TCaption;
begin
  Result := FCaption;
end;

procedure TxpButton.SetDowned (ADowned : Boolean);
begin
  if FDowned <> ADowned then
  Begin
    FDowned := ADowned;
    Repaint;
  end;
end;

function  TxpButton.GetDowned : Boolean;
begin
  Result := FDowned;
end;


procedure TxpButton.SetFont (AFont : TFont);
begin
  FFont.Assign (AFont);
  RePaint;
end;

function  TxpButton.GetFont : TFont;
begin
  Result := FFont;
end;


procedure TxpButton.LMouseDblClick  (var Message : TMessage);
begin
  FOnButtonClick;
end;

procedure TxpButton.LMouseDown  (var Message : TMessage);
begin
  if not FDowned then
  begin
    FDowned := true;
    if (not Focused) and (Enabled) then SetFocus;
    Repaint;
  end;
end;

procedure TxpButton.RMouseDown  (var Message : TMessage);
begin

end;

procedure TxpButton.LMouseUp  (var Message : TMessage);
begin
  if FDowned then
  begin
    FDowned := False;
    Repaint;
    FOnButtonClick;
  end;
end;

procedure TxpButton.RMouseUp  (var Message : TMessage);
begin

end;

procedure TxpButton.CMEnter(var Message: TCMGotFocus);
begin
  inherited;
  if Assigned (FOnEnter) then FOnEnter (self);
end;

procedure TxpButton.CMExit(var Message: TCMLostFocus);
begin
  inherited;
  if Assigned (FOnExit) then FOnExit (self);
end;

procedure TxpButton.WMSetFocus(var Message: TMessage);
begin
  if not FFocused then
  begin
    FFocused := true;
    Invalidate;
  end;  
end;

procedure TxpButton.WMKillFocus(var Message: TMessage);
begin
  if FFocused then
  begin
    FFocused := False;
    Invalidate;
  end;  
end;

procedure TxpButton.WMKeyDown (var Message: TMessage);
begin
  if (not FDowned) and ((Message.WParam = VK_RETURN) or (Message.WParam = VK_SPACE)) then
  Begin
    FDowned := true;
    Invalidate;
  end;
  inherited;
end;

procedure TxpButton.WMKeyUp (var Message: TMessage);
Begin
  if FDowned then
  begin
    FDowned := False;
    Invalidate;
    FOnButtonClick;
  end;
  inherited;
end;


procedure TxpButton.SetModalResult (AModalResult : TModalResult);
begin
  FModalResult := AModalResult;
end;

function  TxpButton.GetModalResult : TModalResult;
begin
  Result := FModalResult;
end;

procedure TxpButton.FOnButtonClick;
begin
  if Assigned (FOnClick) then FOnClick (Self);
  if (FModalResult <> mrNone) and (Owner.InheritsFrom (TCustomForm)) then
    (Owner as TCustomForm).ModalResult := FModalResult;
end;

procedure TxpButton.CMDialogChar(var Message : TCMDialogChar);
begin
  if IsAccel (Message.CharCode, FCaption) then
    FOnButtonClick;
end;

procedure Register;
begin
  RegisterComponents('XP Controls', [TxpButton]);
end;

end.