unit CheckboxX;

interface

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

const
  fRBoxWidth : Integer =  13 ;
  fRBoxHeight : Integer =  13 ;

type
  TState = (cbUnchecked,cbChecked,cbGrayed);
  TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect);
  TMouseState = (msMouseUp,msMouseDown);
  TAlignment = (taRightJustify,taLeftJustify);

  TCheckboxX = class(TCustomControl)

  private
    { Private declarations }
    fChecked : Boolean;
    fCaption : string;
    fColor : TColor;
    fState : TState;
    fFont : TFont;
    fAllowGrayed : Boolean;
    fFocus : Boolean;
    fType : TType;
    fMouseState : TMouseState;
    fAlignment : TAlignment;
    fTextTop : Integer;
    fTextLeft : Integer;
    fBoxTop : Integer;
    fBoxLeft : Integer;

    procedure fSetChecked(Bo : Boolean);
    procedure fSetCaption(S : string);
    procedure fSetColor(C : TColor);
    procedure fSetState(cbState : TState);
    procedure fSetFont(cbFont : TFont);
    procedure fSetAllowGrayed(Bo : Boolean);
    procedure fSetType(T : TType);
    procedure fSetAlignment(A : TAlignment);

  protected
    { Protected declarations }
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
    X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
    X, Y: Integer); override;
    procedure WMKillFocus(var message : TWMKillFocus); message WM_KILLFOCUS;
    procedure WMSetFocus(var message : TWMSetFocus); message WM_SETFOCUS;
    procedure KeyDown(var Key : Word; Shift : TShiftState); override;
    procedure KeyUp(var Key : Word; Shift : TShiftState); override;

  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;

  published
    { Published declarations }
    property Action;
    property Alignment : TAlignment
    read fAlignment write fSetAlignment;
    property AllowGrayed : Boolean
    read fAllowGrayed write fSetAllowGrayed;
    property Anchors;
    property BiDiMode;
    property Caption : string
    read fCaption write fSetCaption;
    property CheckBoxType : TType
    read fType write fSetType;
    property Checked : Boolean
    read fChecked write fSetChecked;
    property Color : TColor
    read fColor write fSetColor;
    property Constraints;
    property Cursor;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font : TFont
    read fFont write fSetFont;
    property HelpContext;
    property Hint;
    property Left;
    property name;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property State : TState
    read fState write fSetState;
    property TabOrder;
    property TabStop;
    property Tag;
    property Top;
    property Visible;

    property OnClick;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
end;

procedure register;

implementation

procedure TCheckboxX.KeyDown(var Key : Word; Shift : TShiftState);
begin
  if fFocus then
    if Shift = [] then
      if Key =  0032  then
      begin
        fMouseState := msMouseDown;
        if fState <> cbGrayed then
        begin
          SetFocus;
          fFocus := True;
          Invalidate;
        end;
      end;
  inherited KeyDown(Key,Shift);
end;

procedure TCheckboxX.KeyUp(var Key : Word; Shift : TShiftState);
begin
  if fFocus then
    if Shift = [] then
      if Key =  0032  then
      begin
        if fState <> cbGrayed then
          fSetChecked(not fChecked);
        fMouseState := msMouseUp;
      end;
  inherited KeyUp(Key,Shift);
end;

procedure TCheckboxX.WMSetFocus(var message : TWMSetFocus);
begin
  fFocus := True;
  Invalidate;
end;

procedure TCheckboxX.WMKillFocus(var message : TWMKillFocus);
begin
  fFocus := False;
  Invalidate;
end;

procedure TCheckboxX.fSetAlignment(A : TAlignment);
begin
  if A <> fAlignment then
  begin
    fAlignment := A;
    Invalidate;
  end;
end;

procedure TCheckboxX.fSetType(T : TType);
begin
  if fType <> T then
  begin
    fType := T;
    Invalidate;
  end;
end;

procedure TCheckboxX.fSetFont(cbFont : TFont);
var
  FontChanged : Boolean;
begin
  FontChanged := False;

  if fFont.Style <> cbFont.Style then
  begin
    fFont.Style := cbFont.Style;
    FontChanged := True;
  end;

  if fFont.CharSet <> cbFont.Charset then
  begin
    fFont.Charset := cbFont.Charset;
    FontChanged := True;
  end;

  if fFont.Size <> cbFont.Size then
  begin
    fFont.Size := cbFont.Size;
    FontChanged := True;
  end;

  if fFont.name <> cbFont.name then
  begin
    fFont.name := cbFont.name;
    FontChanged := True;
  end;

  if fFont.Color <> cbFont.Color then
  begin
    fFont.Color := cbFont.Color;
    FontChanged := True;
  end;

  if FontChanged then
    Invalidate;
end;

procedure TCheckboxX.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  fMouseState := msMouseDown;
  if fState <> cbGrayed then
  begin
    SetFocus;
    fFocus := True;
    Invalidate;
  end;
end;

procedure TCheckboxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if fState <> cbGrayed then
    fSetChecked(not fChecked);
  fMouseState := msMouseUp;
end;

procedure TCheckboxX.fSetAllowGrayed(Bo : Boolean);
begin
  if fAllowGrayed <> Bo then
  begin
    fAllowGrayed := Bo;
    if not fAllowGrayed then
      if fState = cbGrayed then
      begin
        if fChecked then
          fState := cbChecked
        else
          fState := cbUnChecked;
      end;
    Invalidate;
  end;
end;

procedure TCheckboxX.fSetState(cbState : TState);
begin
  if fState <> cbState then
  begin
    fState := cbState;
    if (fState = cbChecked) then
      fChecked := True;

    if (fState = cbGrayed) then
      fAllowGrayed := True;

    if fState = cbUnChecked then
      fChecked := False;

    Invalidate;
  end;
end;

procedure TCheckboxX.fSetColor(C : TColor);
begin
  if fColor <> C then
  begin
    fColor := C;
    Invalidate;
  end;
end;

procedure TCheckboxX.fSetCaption(S : string);
begin
  if fCaption <> S then
  begin
    fCaption := S;
    Invalidate;
  end;
end;

procedure TCheckboxX.fSetChecked(Bo : Boolean);
begin
  if fChecked <> Bo then
  begin
    fChecked := Bo;
    if fState <> cbGrayed then
    begin
      if fChecked then
        fState := cbChecked
      else
        fState := cbUnChecked;
    end;
    Invalidate;
  end;
end;

procedure TCheckboxX.Paint;
var
  Buffer : array[ 0 .. 127 ] of Char;
  I : Integer;
  fTextWidth,fTextHeight : Integer;
begin
  GetTextBuf(Buffer,SizeOf(Buffer));
  if Buffer <> '' then
    fCaption := Buffer;

  Canvas.Font.Size := Font.Size;
  Canvas.Font.Style := Font.Style;
  Canvas.Font.Color := Font.Color;
  Canvas.Font.Charset := Font.CharSet;

  fTextWidth := Canvas.TextWidth(fCaption);
  fTextHeight := Canvas.TextHeight('Q');

  if fAlignment = taRightJustify then
  begin
    fBoxTop := (Height - fRBoxHeight) div  2 ;
    fBoxLeft :=  0 ;
    fTextTop := (Height - fTextHeight) div  2 ;
    fTextLeft := fBoxLeft + fRBoxWidth +  4 ;
  end
  else
  begin
    fBoxTop := (Height - fRBoxHeight) div  2 ;
    fBoxLeft := Width - fRBoxWidth;
    fTextTop := (Height - fTextHeight) div  2 ;
    fTextLeft :=  1 ;
  end;

  Canvas.Pen.Color := fFont.Color;
  Canvas.Brush.Color := fColor;
  Canvas.TextOut(fTextLeft,fTextTop,fCaption);

  if fFocus = True then
    Canvas.DrawFocusRect(Rect(fTextLeft -  1 ,
    fTextTop -  2 , fTextLeft + fTextWidth +  1 , fTextTop + fTextHeight +  2 ));

  if (fState = cbChecked) then
    Canvas.Brush.Color := clWindow;

  if (fState = cbUnChecked) then
    Canvas.Brush.Color := clWindow;

  if (fState = cbGrayed) then
  begin
    fAllowGrayed := True;
    Canvas.Brush.Color := clBtnFace;
  end;

  if fMouseState = msMouseDown then
    Canvas.Brush.Color := clBtnFace;

  Canvas.FillRect(Rect(fBoxLeft +  2 ,
  fBoxTop +  2 ,
  fBoxLeft + fRBoxWidth -  2 ,
  fBoxTop + fRBoxHeight -  2 ));

  Canvas.Brush.Color := clBtnFace;
  Canvas.Pen.Color := clGray;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth -  1 ,fBoxTop);
  Canvas.LineTo(fBoxLeft,fBoxTop);
  Canvas.LineTo(fBoxLeft,fBoxTop + fRBoxHeight);

  Canvas.Pen.Color := clWhite;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth -  1 ,fBoxTop);
  Canvas.LineTo(fBoxLeft + fRBoxWidth -  1 ,
  fBoxTop + fRBoxHeight -  1 );
  Canvas.LineTo(fBoxLeft -  1 ,fBoxTop + fRBoxHeight -  1 );

  Canvas.Pen.Color := clBlack;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth -  3 ,fBoxTop +  1 );
  Canvas.LineTo(fBoxLeft +  1 ,fBoxTop +  1 );
  Canvas.LineTo(fBoxLeft +  1 ,fBoxTop + fRBoxHeight -  2 );

  Canvas.Pen.Color := clBtnFace;
  Canvas.MoveTo(fBoxLeft + fRBoxWidth -  2 ,fBoxTop +  1 );
  Canvas.LineTo(fBoxLeft + fRBoxWidth -  2 ,
  fBoxTop + fRBoxHeight -  2 );
  Canvas.LineTo(fBoxLeft,fBoxTop + fRBoxHeight -  2 );


  if fChecked then
  begin
    Canvas.Pen.Color := clBlack;
    Canvas.Brush.Color := clBlack;

    if fType = cbRect then
    begin
      Canvas.FillRect(Rect(fBoxLeft +  4 ,fBoxTop +  4 ,
      fBoxLeft + fRBoxWidth -  4 ,fBoxTop + fRBoxHeight -  4 ));
    end;

    if fType = cbBullet then
    begin
      Canvas.Ellipse(fBoxLeft +  4 ,fBoxTop +  4 ,
      fBoxLeft + fRBoxWidth -  4 ,fBoxTop + fRBoxHeight -  4 );
    end;

    if fType = cbCross then
    begin
      Canvas.MoveTo(fBoxLeft + fRBoxWidth -  5 ,fBoxTop +  3 );
      Canvas.LineTo(fBoxLeft +  2 ,fBoxTop + fRBoxHeight -  4 );
      Canvas.MoveTo(fBoxLeft + fRBoxWidth -  4 ,fBoxTop +  3 );
      Canvas.LineTo(fBoxLeft +  2 ,fBoxTop + fRBoxHeight -  3 );
      Canvas.MoveTo(fBoxLeft + fRBoxWidth -  4 ,fBoxTop +  4 );
      Canvas.LineTo(fBoxLeft +  3 ,fBoxTop + fRBoxHeight -  3 );

      Canvas.MoveTo(fBoxLeft +  3 ,fBoxTop +  4 );
      Canvas.LineTo(fBoxLeft + fRBoxWidth -  4 ,
      fBoxTop + fRBoxHeight -  3 );
      Canvas.MoveTo(fBoxLeft +  3 ,fBoxTop +  3 );
      Canvas.LineTo(fBoxLeft + fRBoxWidth -  3 ,
      fBoxTop + fRBoxHeight -  3 );
      Canvas.MoveTo(fBoxLeft +  4 ,fBoxTop +  3 );
      Canvas.LineTo(fBoxLeft + fRBoxWidth -  3 ,
      fBoxTop + fRBoxHeight -  4 );
    end;

    if fType = cbMark then
      for I :=  0  to  2  do
      begin

        Canvas.MoveTo(fBoxLeft +  3 ,fBoxTop +  5  + I);
        Canvas.LineTo(fBoxLeft +  6 ,fBoxTop +  8  + I);

        Canvas.MoveTo(fBoxLeft +  6 ,fBoxTop +  6  + I);
        Canvas.LineTo(fBoxLeft +  10 ,fBoxTop +  2  + I);
      end;


    if fType = cbDiamond then
    begin
      Canvas.Pixels[fBoxLeft +  06 ,fBoxTop +  03 ] := clBlack;
      Canvas.Pixels[fBoxLeft +  06 ,fBoxTop +  09 ] := clBlack;

      Canvas.MoveTo(fBoxLeft +  05 ,fBoxTop +  04 );
      Canvas.LineTo(fBoxLeft +  08 ,fBoxTop +  04 );

      Canvas.MoveTo(fBoxLeft +  05 ,fBoxTop +  08 );
      Canvas.LineTo(fBoxLeft +  08 ,fBoxTop +  08 );

      Canvas.MoveTo(fBoxLeft +  04 ,fBoxTop +  05 );
      Canvas.LineTo(fBoxLeft +  09 ,fBoxTop +  05 );

      Canvas.MoveTo(fBoxLeft +  04 ,fBoxTop +  07 );
      Canvas.LineTo(fBoxLeft +  09 ,fBoxTop +  07 );

      Canvas.MoveTo(fBoxLeft +  03 ,fBoxTop +  06 );
      Canvas.LineTo(fBoxLeft +  10 ,fBoxTop +  06 );
    end;
  end;
end;

procedure register;
begin
  RegisterComponents('John', [TCheckBoxX]);
end;

destructor TCheckboxX.Destroy;
begin
  inherited Destroy;
end;

constructor TCheckboxX.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Height :=  17 ;
  Width :=  97 ;
  fChecked := False;
  fColor := clBtnFace;
  fState := cbUnChecked;
  fFont := inherited Font;
  fAllowGrayed := False;
  fFocus := False;
  fMouseState := msMouseUp;
  fAlignment := taRightJustify;
  TabStop := True; 
end;

end.