xpcheckbox.pas

非常好的xp界面控件

{
 Copyright:      rhoStyle Developers team
 mailto:         [e-mail]
 Author:         rhoStyle
 Version:        2.4
 Delphi Version: Delphi 3-7
 Description:    This is Windows XP style checkbox. You can use it with
		 Windows 95, 98, NT, ME, 2000 and XP

}


unit xpCheckBox;

interface

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

type
  TCheckBoxAlignment = (cbaLeft, cbaRight);

  TxpCheckBox = class(TCustomControl)
  private
    FCaption : TCaption;
    FActive  : Boolean;
    FChecked : Boolean;
    FEnabled : Boolean;
    FDowned  : Boolean;
    FFont    : TFont;
    FFocused : Boolean;
    FHotKey  : Char;
    FAlignment : TCheckBoxAlignment;
    FColor   : TColor;
    FShadowText : Boolean;
    FCheckColor : TColor;
    FUnderLineOnActive : Boolean;

    FTransparent : Boolean;

    FOnClick : TNotifyEvent;
    FOnEnter : TNotifyEvent;
    FOnExit  : TNotifyEvent;

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

    procedure SetFont (AFont : TFont);
    function  GetFont : TFont;
    procedure OnFontChange (Sender : TObject);

    procedure SetColor (AColor : TColor);
    function  GetColor : TColor;

    procedure SetCheckColor (AColor : TColor);
    function  GetCheckColor : TColor;

    procedure SetChecked (AChecked : Boolean);
    function  GetChecked : Boolean;

    procedure SetUnderLine (AUnderLine : Boolean);
    function  GetUnderLine : Boolean;

    procedure SetAlignment (AAlignment : TCheckBoxAlignment);
    function  GetAlignment : TCheckBoxAlignment;

    procedure SetTransparent (Value : Boolean);

    procedure SetEnabled (AValue : Boolean);

    procedure SetShadowText (AValue : Boolean);
  protected
    procedure Paint; override;
    procedure DrawCheckArea (ACanvas : TCanvas);
    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 WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
    procedure CMDialogChar(var Message : TCMDialogChar);  message CM_DIALOGCHAR;
    procedure WMKeyDown(var Message: TMessage); message WM_KEYDOWN;
    procedure WMKeyUp(var Message: TMessage); message WM_KEYUP;
    procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
    procedure CMExit(var Message: TCMLostFocus); message CM_EXIT;

    procedure FOnCheckBoxClick;
  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 : Boolean read FEnabled write SetEnabled default true;
    property ParentFont;
    property ParentColor;
    property Hint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    //property Transparent : Boolean read FTransparent write SetTransparent default true;
    property ShadowText : Boolean read FShadowText write SetShadowText default True;
    property Color : TColor read GetColor write SetColor;
    property CheckColor : TColor read GetCheckColor write SetCheckColor;
    property Checked : Boolean read GetChecked write SetChecked default False;
    property UnderLineOnActive : Boolean read GetUnderLine write SetUnderLine default False;
    property Alignment : TCheckBoxAlignment read GetAlignment write SetAlignment;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
  end;

procedure Register;

implementation


constructor TxpCheckBox.Create (AOwner : TComponent);
begin
  Inherited Create (AOwner);
  Width := 97;
  Height := 17;
  FFont := TFont.Create;
  FFont.OnChange := OnFontChange;

  FCaption := 'XP Checkbox';
  FEnabled := True;
  FChecked := False;
  FFocused := False;
  FDowned := False;
  FAlignment := cbaRight;

  FColor := clBtnFace;

  FCheckColor := RGB (0, 160, 0);
  FUnderLineOnActive := False;
  FShadowText := true;
  TabStop := True;
end;

destructor TxpCheckBox.Destroy;
begin
  try FFont.Free; except end;
  inherited;
end;


procedure TxpCheckBox.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  TxpCheckBox.GetCaption : TCaption;
begin
  Result := FCaption;
end;

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

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

procedure TxpCheckBox.OnFontChange (Sender : TObject);
begin
  Invalidate;
end;

procedure TxpCheckBox.SetColor (AColor : TColor);
begin
  if FColor <> AColor then
  begin
    FColor := AColor;
    ParentColor := False;
    Invalidate;
  end;
end;

function  TxpCheckBox.GetColor : TColor;
begin
  Result := FColor;
end;

procedure TxpCheckBox.SetCheckColor (AColor : TColor);
begin
  if FCheckColor <> AColor then
  begin
    FCheckColor := AColor;
    Invalidate;
  end;
end;

function  TxpCheckBox.GetCheckColor : TColor;
begin
  Result := FCheckColor;
end;


procedure TxpCheckBox.SetChecked (AChecked : Boolean);
begin
  if FChecked <> AChecked then
  begin
    FChecked := AChecked;
    Repaint;
  end;
end;

function  TxpCheckBox.GetChecked : Boolean;
begin
 Result := FChecked;
end;


procedure TxpCheckBox.SetAlignment (AAlignment : TCheckBoxAlignment);
begin
  if FAlignment <> AAlignment then
  begin
    FAlignment := AAlignment;
    Repaint;
  end;
end;

function  TxpCheckBox.GetAlignment : TCheckBoxAlignment;
begin
 Result := FAlignment;
end;

procedure TxpCheckBox.SetUnderLine (AUnderLine : Boolean);
begin
  if FUnderLineOnActive <> AUnderLine then
  begin
    FUnderLineOnActive := AUnderLine;
  end;
end;

function  TxpCheckBox.GetUnderLine : Boolean;
begin
  Result := FUnderLineOnActive;
end;

procedure TxpCheckBox.SetTransparent (Value : Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    if FTransparent then ControlStyle := ControlStyle - [csOpaque] else
      ControlStyle := ControlStyle + [csOpaque];
    Invalidate;
  end;
end;

procedure TxpCheckBox.SetEnabled (AValue : Boolean);
begin
  if FEnabled <> AValue then
  begin
    FEnabled := AValue;
    Enabled := AValue;
    Invalidate;
  end;
end;


procedure TxpCheckBox.SetShadowText (AValue : Boolean);
begin
  if FShadowText <> AValue then
  begin
    FShadowText := AValue;
    Invalidate;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//////////////////   M E S S A G E S   M E T O D S   ///////////////////////////
////////////////////////////////////////////////////////////////////////////////

procedure TxpCheckBox.FOnCheckBoxClick;
begin
  FChecked := not FChecked;
  Invalidate;

  if Assigned (FOnClick) then FOnClick (self);
end;