{

====================================================================

  Обозначения

====================================================================

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;

  fText : Integer; // отступ текта с верху

  fTextLeft : Integer; // отступ текта с лева

  fBox : 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; // Если вы используете клавишу TAB или Shift-Tab

  Procedure KeyDown(var Key : Word; Shift : TShiftState); override;

  // перехват KeyDown

  Procedure KeyUp(var Key : Word; Shift : TShiftState); override;

  // перехват KeyUp

 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 ;

  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

  fBox := (Height - fRBoxHeight) div 2;

  fBoxLeft := 0;

  fText := (Height - fTextHeight) div 2;

  fTextLeft := fBoxLeft + fRBoxWidth + 4;

  end

 else

  begin

  fBox := (Height - fRBoxHeight) div 2;

  fBoxLeft := Width - fRBoxWidth;

  fText := (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, fText, fCaption);

// Рисуем контур фокуса

 if fFocus = True then

  Canvas.DrawFocusRect(Rect(fTextLeft - 1,

  fText - 2,

  fTextLeft + fTextWidth + 1,

  fText + 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,

  fBox + 2,

  fBoxLeft + fRBoxWidth - 2,

  fBox + fRBoxHeight - 2));

// Рисуем прямоугольный чекбокс

 Canvas.Brush.Color := clBtnFace;

 Canvas.Pen.Color := clGray;

 Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBox);

 Canvas.LineTo(fBoxLeft, fBox);

 Canvas.LineTo(fBoxLeft, fBox + fRBoxHeight);

 Canvas.Pen.Color := clWhite;

 Canvas.MoveTo(fBoxLeft + fRBoxWidth - 1, fBox);

 Canvas.LineTo(fBoxLeft + fRBoxWidth - 1,

  fBox + fRBoxHeight - 1);

 Canvas.LineTo(fBoxLeft - 1, fBox + fRBoxHeight - 1);

 Canvas.Pen.Color := clBlack;

 Canvas.MoveTo(fBoxLeft + fRBoxWidth - 3, fBox + 1);

 Canvas.LineTo(fBoxLeft + 1, fBox + 1);

 Canvas.LineTo(fBoxLeft + 1, fBox + fRBoxHeight - 2);

 Canvas.Pen.Color := clBtnFace;

 Canvas.MoveTo(fBoxLeft + fRBoxWidth - 2, fBox + 1);

 Canvas.LineTo(fBoxLeft + fRBoxWidth - 2,

  fBox + fRBoxHeight - 2);

 Canvas.LineTo(fBoxLeft, fBox + 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, fBox + 4,

  fBoxLeft + fRBoxWidth - 4, fBox + fRBoxHeight - 4));

  end;

  // Рисуем значёк "о"

  if fType = cbBullet then

  begin

  Canvas.Ellipse(fBoxLeft + 4, fBox + 4,

  fBoxLeft + fRBoxWidth - 4, fBox + fRBoxHeight - 4);

  end;

  // Рисуем крестик

  if fType = cbCross then

  begin

  {Right-top to left-bottom}

  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 5, fBox + 3);

  Canvas.LineTo(fBoxLeft + 2, fBox + fRBoxHeight - 4);

  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBox + 3);

  Canvas.LineTo(fBoxLeft + 2, fBox + fRBoxHeight - 3);

  Canvas.MoveTo(fBoxLeft + fRBoxWidth - 4, fBox + 4);

  Canvas.LineTo(fBoxLeft + 3, fBox + fRBoxHeight - 3);

  {Left-top to right-bottom}

  Canvas.MoveTo(fBoxLeft + 3, fBox + 4);

  Canvas.LineTo(fBoxLeft + fRBoxWidth - 4,

  fBox + fRBoxHeight - 3);

  Canvas.MoveTo(fBoxLeft + 3, fBox + 3);

  Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,

  fBox + fRBoxHeight - 3); //mid

  Canvas.MoveTo(fBoxLeft + 4, fBox + 3);

  Canvas.LineTo(fBoxLeft + fRBoxWidth - 3,

  fBox + fRBoxHeight - 4);

  end;

  // Рисуем галочку

  if fType = cbMark then

  for I := 0 to 2 do

  begin

  {Left-mid to left-bottom}

  Canvas.MoveTo(fBoxLeft + 3, fBox + 5 + I);

  Canvas.LineTo(fBoxLeft + 6, fBox + 8 + I);

  {Left-bottom to right-top}

  Canvas.MoveTo(fBoxLeft + 6, fBox + 6 + I);

  Canvas.LineTo(fBoxLeft + 10, fBox + 2 + I);

  end;

  // Рисуем бриллиантик

  if fType = cbDiamond then

  begin

  Canvas.Pixels[fBoxLeft + 06, fBox + 03] := clBlack;

  Canvas.Pixels[fBoxLeft + 06, fBox + 09] := clBlack;

  Canvas.MoveTo(fBoxLeft + 05, fBox + 04);

  Canvas.LineTo(fBoxLeft + 08, fBox + 04);

  Canvas.MoveTo(fBoxLeft + 05, fBox + 08);

  Canvas.LineTo(fBoxLeft + 08, fBox + 08);

  Canvas.MoveTo(fBoxLeft + 04, fBox + 05);

  Canvas.LineTo(fBoxLeft + 09, fBox + 05);

  Canvas.MoveTo(fBoxLeft + 04, fBox + 07);

  Canvas.LineTo(fBoxLeft + 09, fBox + 07);

  Canvas.MoveTo(fBoxLeft + 03, fBox + 06);

  Canvas.LineTo(fBoxLeft + 10, fBox + 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.

{===================================================================}