xpcheckbox.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 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;

type
  TCheckBoxAlignment = (cbaLeft, cbaRight);

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

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

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

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

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

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

    procedure SetAlignment (AAlignment : TCheckBoxAlignment);
    function  GetAlignment : TCheckBoxAlignment;
  protected
    procedure Paint; override;
    procedure DrawCheckArea;
    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;
    property ParentFont;
    property Hint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Color : TColor read GetColor write SetColor;
    property Checked : Boolean read GetChecked write SetChecked 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;
  FCaption := 'XP Checkbox';
  Enabled := True;
  FChecked := False;
  FFocused := False;
  FDowned := False;
  TabStop := true;
  FAlignment := cbaRight;
  FColor := clBtnFace;
end;

destructor TxpCheckBox.Destroy;
begin
  FFont.Free;
  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.SetColor (AColor : TColor);
begin
  if FColor <> AColor then
  begin
    FColor := AColor;
    Invalidate;
  end;  
end;

function  TxpCheckBox.GetColor : TColor;
begin
  Result := FColor;
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;


////////////////////////////////////////////////////////////////////////////////
//////////////////   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;


procedure TxpCheckBox.CMDialogChar(var Message : TCMDialogChar);
begin
  if Enabled and (IsAccel (Message.CharCode, FCaption)) then
  begin
    if not FFocused then SetFocus;
    FOnCheckBoxClick;
  end;
end;

procedure TxpCheckBox.MouseEnter (var Message : TMessage);
begin
  if not FActive then
  begin
    FActive := true;
    Invalidate;
  end;
end;

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

procedure TxpCheckBox.LMouseDblClick  (var Message : TMessage);
begin
  FOnCheckBoxClick;
end;

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

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

end;

procedure TxpCheckBox.LMouseUp  (var Message : TMessage);
begin
  if FDowned then
  begin
    FDowned := False;
    Invalidate;
    FOnCheckBoxClick;
  end;
end;

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

end;

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

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

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

procedure TxpCheckBox.WMKeyUp(var Message: TMessage);
begin
  if FDowned then
  begin
    FDowned := False;
    FOnCheckBoxClick;
  end;
end;

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

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



////////////////////////////////////////////////////////////////////////////////
////////////////// D R A W I N G   M E T O D S /////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

procedure TxpCheckBox.DrawCheckArea;
var
  CheckRect : TRect;
begin
  if FAlignment = cbaRight then
  begin
    CheckRect := Rect (1, HeightOf (ClientRect) div 2 - 7,
                       15, HeightOf (ClientRect) div 2 + 7);
  end
  else
  Begin
    CheckRect := Rect (Width - 15, HeightOf (ClientRect) div 2 - 7,
                       Width - 1, HeightOf (ClientRect) div 2 + 7);
  end;


  if Enabled then
  begin
    if FDowned then
    begin
      GradientFillRect (Canvas, CheckRect, RGB (176, 176, 167), RGB (241, 239, 223),
        fdTopToBottom, 10);
    end
    else
    begin // not FDowned
      if FActive then
      begin
        GradientFillRect (Canvas, CheckRect, RGB (255, 240, 207), RGB (248, 179, 48),
          fdTopToBottom, 10);
        Canvas.Brush.Style := bsSolid;
        Canvas.Pen.Style := psClear;
        Canvas.Pen.Color := clBtnFace;
        Canvas.Rectangle (CheckRect.Left+2, CheckRect.Top+2, CheckRect.Right-2, CheckRect.Bottom-2);
        Canvas.Pen.Style := psSolid;
      end
      else
        GradientFillRect (Canvas, CheckRect, RGB (220, 220, 215), RGB (255, 255, 255),
          fdTopToBottom, 10);
    end;
  end;

  Canvas.Pen.Width := 1;
  if Enabled then
  begin
    Canvas.Pen.Color := RGB (28, 81, 128);
    Canvas.Brush.Style := bsClear;
  end
  else
  begin
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Color := clGray;
    Canvas.Brush.Style := bsSolid;
    Canvas.Brush.Color := clWhite;
  end;
  Canvas.Rectangle (CheckRect.Left, CheckRect.Top, CheckRect.Right, CheckRect.Bottom);

  if FChecked then
  begin
    Canvas.Pen.Width := 3;
    if Enabled then Canvas.Pen.Color := RGB (0, 160, 0)
      else Canvas.Pen.Color := clLtGray;
    Canvas.MoveTo (CheckRect.Left + 3, CheckRect.Top + 6);
    Canvas.LineTo (CheckRect.Left + 5, CheckRect.Bottom - 5);
    Canvas.LineTo (CheckRect.Right - 5, CheckRect.Top + 4);
  end;

end;

procedure TxpCheckBox.Paint;
var
  AText : String;
begin
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := FColor;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect (ClientRect);

  DrawCheckArea;

  AText := FCaption;
  if Pos ('&', FCaption) <> 0 then Delete (AText, Pos ('&', AText), 1);


  Canvas.Font := FFont;
  Canvas.Brush.Color := FColor;

  if not Enabled then Canvas.Font.Color := clGray;

  if FAlignment = cbaRight then
  begin
    Canvas.TextRect (Rect (20, 2, Width-2, Height),
      20, (Height - Canvas.TextHeight (AText)) div 2, AText);

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

  if Enabled and FFocused then
  begin
    Canvas.Brush.Style := bsSolid;
    if FAlignment = cbaRight then
      Canvas.DrawFocusRect (Rect (17, 1, Canvas.TextWidth (AText) + 25, Height - 1))
    else
      Canvas.DrawFocusRect (Rect (1, 1, Canvas.TextWidth (AText) + 8, Height - 1));
  end;

end;


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

end.