Видоизменяем чекбоксы в Delphi

{
==========================================
Обозначения
==========================================
X = крестик
V = галочка
o = кружок

+-+
|W| = заполненный прямоугольник
+-+

/\
= бриллиантик
\/


Преимущества этого чекбокса

Вы можете найти множество чекбоксов в интернете.
Но у них есть недостаток, они не обрабатывают сообщение WM_KILLFOCUS.
Приведённый ниже пример делает это.
}

unit CheckBoxX;

interface

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

const
  { другие константы }
  fRBoxWidth : Integer = 13; // ширина квадрата checkbox
  fRBoxHeight : Integer = 13; // высота квадрата checkbox

type
  TState = (cbUnchecked,cbChecked,cbGrayed); // такой же как в Delphi
  TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // добавленный
  TMouseState = (msMouseUp,msMouseDown);
  TAlignment = (taRightJustify,taLeftJustify); // The same

  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;
    // Если вы используете клавишу TAB или Shift-Tab
    procedure WMSetFocus(var message : TWMSetFocus); message WM_SETFOCUS;
    // перехват KeyDown
    procedure KeyDown(var Key : Word; Shift : TShiftState); override;
    // перехват KeyUp
    procedure KeyUp(var Key : Word; Shift : TShiftState); override;

  public
    { Public declarations }
    // Если поместить Create и Destroy в раздел protected,
    // то Delphi начинает ругаться.
    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 Ctrl3D;
    property Cursor;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font : TFont
    read fFont write fSetFont;
    //Property Height;
    property HelpContext;
    property Hint;
    property Left;
    property name;
    //Property PartenBiDiMode;
    property ParentColor;
    //Property ParentCtrl3D;
    property ParentFont;
    property ParentShowHint;
    //Property PopMenu;
    property ShowHint;
    property State : TState
    read fState write fSetState;
    property TabOrder;
    property TabStop;
    property Tag;
    property Top;
    property Visible;
    //Property Width;

    { --- Events --- }
    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; //Hello!

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; // Устанавливаем фокус на этот компонент
          // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
          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
  // Процедура MouseDown вызывается, когда кнопка мышки нажимается в пределах
  // кнопки, соответственно мы не можем получить значения координат X и Y.
  inherited MouseDown(Button, Shift, X, Y);
  fMouseState := msMouseDown;
  if fState <> cbGrayed then
  begin
    SetFocus; // Устанавливаем фокус на этот компонент
    // всем другим компонентам Windows посылает сообщение WM_KILLFOCUS.
    fFocus := True;
    Invalidate;
  end;
end;

procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
  // Процедура MouseUp вызывается, когда кнопка мышки отпускается в пределах
  // кнопки, соответственно мы не можем получить значения координат X и Y.
  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
  {Get Delphi's componentname and initially write it in the caption}
  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;
    //If fTextWidth > (Width - fBoxWidth - 4) then
    // fTextLeft := (Width - fBoxWidth - 4) - fTextWidth;
  end;

  // выводим текст в caption
  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;

  // Создаём бокс clBtnFace когда кнопка мыши нажимается
  // наподобие "стандартного" CheckBox
  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);

  // Теперь он должен быть таким же как чекбокс в Delphi

  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
      {Right-top to left-bottom}
      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);
      {Left-top to right-bottom}
      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); //mid
      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
        {Left-mid to left-bottom}
        Canvas.MoveTo(fBoxLeft + 3,fBoxTop + 5 + I);
        Canvas.LineTo(fBoxLeft + 6,fBoxTop + 8 + I);
        {Left-bottom to right-top}
        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); // middle line
    end;
  end;
end;

procedure register;
begin
  RegisterComponents('Samples', [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; // Sorry
end;

end.