xpbutton.pas

XP_Buttons for delphi7 绝对精典的按钮控件

//==============================================================================
//  XPButton.pas
//  Author : SteedSky
//  Modify Data : 2003.08.20
//  E-Mail : [e-mail]
//==============================================================================
unit XPButton;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   ActnList, StdCtrls, ImgList, XPButtonClass, ExtCtrls;

type
  TXPButton = class(TCustomControl)
  private
    FButtonStyle : TButtonStyle ;
    FBorderColor: TColor;
    FBorderDraw : Boolean;
    FCanFocus : Boolean ;
    FCancel : Boolean ;
    FDefault : Boolean ;
    FDragging: Boolean;
    FGradientBeginColor : TColor ;
    FGradientEndColor: TColor;
    FGlyph: TBitmap;
    FKind: TButtonKind;
    FLayout: TButtonLayout;
    FMargin: Integer;
    FMouseInControl: Boolean;
    FModalResult: TModalResult;
    FNumGlyphs: TNumGlyphs;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FSpacing: Integer;
    FState: TButtonState;
    GlyphPos: TPoint;
    TextBounds: TRect;

    procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged (var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged (var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange (var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMParentColorChanged (var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure DoDialogKey(var Message: TCMDialogKey);message CM_DIALOGKEY;
    procedure DoDialogChar(var Message: TCMDialogChar);message CM_DIALOGCHAR;
    procedure DoFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CalcButtonLayout (Canvas: TCanvas; const Client: TRect; const Offset: TPoint; Layout: TButtonLayout; Spacing, Margin: Integer; FGlyph: TBitmap; FNumGlyphs: Integer; const Caption: string; var TextBounds: TRect; var GlyphPos: TPoint);
    procedure DrawFocus(Canvas: TCanvas; ARect: TRect);
    procedure PaintButton(Canvas: TCanvas; ARect: TRect) ;
    procedure RemoveMouseTimer;
    procedure SetCanFocus(Value: Boolean);
    procedure SetKind(Value: TButtonKind);
    procedure SetColors (Value: TColor);
    procedure SetGlyph (Value: TBitmap);
    procedure SetNumGlyphs (Value: TNumGlyphs);
    procedure SetLayout (Value: TButtonLayout);
    procedure SetSpacing (Value: Integer);
    procedure SetMargin (Value: Integer);
    procedure SetGradientBeginColor(const Value: TColor);
    procedure SetGradientEndColor(const Value: TColor);
    procedure SetBorderDraw(const Value: Boolean);
    procedure SetButtonStyle(const Value: TButtonStyle);
    procedure UpdateTracking;
  protected
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure Loaded; override;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove (Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseTimerHandler (Sender: TObject);
    procedure Paint; override;
    function IsCustom: Boolean;
    function GetPalette: HPALETTE; override;
    procedure Click; override;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure MouseEnter;
    procedure MouseLeave;
  published
    property Action;
    property Anchors;
    property BiDiMode;
    property BorderColor: TColor read FBorderColor write SetColors default $008396A0;
    property BorderDraw: Boolean read FBorderDraw write SetBorderDraw ;
    property ButtonStyle: TButtonStyle read FButtonStyle write SetButtonStyle ;
    property Constraints;
    property Color ;
    property Caption;
    property CanDrawFocus: Boolean read FCanFocus write SetCanFocus default True;
    property Cancel: Boolean read FCancel write FCancel default False;
    property Default: Boolean read FDefault write FDefault default False;
    property DragKind;
    property Enabled;
    property Font;
    property GradientBeginColor: TColor read FGradientBeginColor write SetGradientBeginColor default clWhite;
    property GradientEndColor: TColor read FGradientEndColor write SetGradientEndColor default clSilver;
    property Glyph: TBitmap read FGlyph write SetGlyph stored IsCustom;
    property Kind: TButtonKind read FKind write SetKind default bkCustom;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
    property Margin: Integer read FMargin write SetMargin default -1;
    property ModalResult: TModalResult read FModalResult write FModalResult stored IsCustom default 0;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ParentBiDiMode;
    property ShowHint;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property TabOrder;
    property TabStop default True;
    property Visible;

    property OnClick;
    property OnEndDock;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnStartDock;
  end;

var
  MouseInControl: TXPButton = nil;

procedure Register;

implementation

var
  MouseTimer: TTimer = nil;
  ControlCounter: Integer = 0;

procedure Register;
begin
   RegisterComponents('JxcVCL', [TXPButton]);
end;

constructor TXPButton.Create(aOwner: TComponent);
begin
  inherited Create(AOwner);
  if MouseTimer = nil then
  begin
    MouseTimer := TTimer.Create(nil);
    MouseTimer.Enabled := False;
    MouseTimer.Interval := 100; // 10 times a second
  end;
  SetBounds(0, 0, 25, 25);
  ControlStyle := [csCaptureMouse, csDoubleClicks];
  Caption := 'XPButton' ;
  FGlyph := TBitmap.Create;
  FKind := bkCustom;
  FNumGlyphs := 1;
  Width := 75;
  Height := 30;
  Font.Charset := GB2312_CHARSET;
  Font.Color := clWindowText;
  Font.Height := -12;
  Font.Name := '宋体';
  Font.Style := [];
  ParentFont := False;
  ParentColor := False;
  FBorderColor := $008396A0;
  Color := clBtnFace ;
  FSpacing := 4;
  FMargin := -1;
  FLayout := blGlyphLeft;
  FModalResult := mrNone;
  Inc(ControlCounter);
  FGradientBeginColor := clWhite;
  FGradientEndColor := clSilver;
  TabStop := True;
  FDefault := False;
  FCancel := False;
  FCanFocus := True ;
  FBorderDraw := True ;
  FButtonStyle := bsGradient ;
end;

destructor TXPButton.Destroy;
begin
  RemoveMouseTimer;
  FGlyph.Free;
  Dec(ControlCounter);
  if ControlCounter = 0 then
  begin
    MouseTimer.Free;
    MouseTimer := nil;
  end;
  inherited Destroy;
end;

procedure TXPButton.UpdateTracking;
var
  P: TPoint;
begin
  if Enabled then
  begin
    GetCursorPos(P);
    FMouseInControl := not (FindDragTarget(P, True) = Self);
    if FMouseInControl then
      MouseLeave
    else
      MouseEnter;
  end;
end;

procedure TXPButton.Loaded;
begin
  inherited Loaded;
  Invalidate;
end;

procedure TXPButton.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then begin
     FState := bsDown;
     FDragging := True;
     SetFocus;
     Invalidate;
  end;
end;

procedure TXPButton.MouseMove (Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
  P: TPoint;
begin
  inherited;
  P := ClientToScreen(Point(X, Y));
  if (MouseInControl <> Self) and (FindDragTarget(P, True) = Self) then
  begin
    if Assigned(MouseInControl) then
      MouseInControl.MouseLeave;
    if (GetActiveWindow <> 0) then
    begin
      if MouseTimer.Enabled then
        MouseTimer.Enabled := False;
      MouseInControl := Self;
      MouseTimer.OnTimer := MouseTimerHandler;
      MouseTimer.Enabled := True;
      MouseEnter;
    end;
  end;

  if FDragging then
  begin
    NewState := bsUp ;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
       NewState := bsDown;
    if NewState <> FState then begin
      FState := NewState;
      Invalidate;
    end;
  end;
end;

procedure TXPButton.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then begin
     FDragging := False;
     DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) ;
     FState := bsUp;
     FMouseInControl := False;
     Invalidate ;
     if DoClick then Click else MouseLeave;
     UpdateTracking;
  end;
end;

procedure TXPButton.Click;
var
  Form: TCustomForm;
  Control: TControl;
begin
  case FKind of
    bkClose:
      begin
        Form := GetParentForm(Self);
        if Form <> nil then Form.Close
        else inherited Click;
      end;
    bkHelp:
      begin
        Control := Self;
        while (Control <> nil) and (Control.HelpContext = 0) do
          Control := Control.Parent;
        if Control <> nil then Application.HelpContext(Control.HelpContext)
        else inherited Click;
      end;
    else
      begin
        Form := GetParentForm(Self);
        if Form <> nil then Form.ModalResult := ModalResult;
        inherited Click;
      end;
  end;
//  Invalidate;
end;

function TXPButton.GetPalette: HPALETTE;
begin
  Result := FGlyph.Palette;
end;

procedure TXPButton.SetColors (Value: TColor);
begin