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

=== Видоизменяем чекбоксы в Delphi ===
В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.
Пример тестировался под WIN95 и WINNT.
{
====================================================================
 Обозначения
====================================================================
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 SetChecked(Bo: boolean);
 procedure SetCaption(S: string);
 procedure SetColor(C: TColor);
 procedure SetState(cbState: TState);
 procedure SetFont(cbFont: TFont);
 procedure SetAllowGrayed(Bo: boolean);
 procedure SetType(T: TType);
 procedure SetAlignment(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 SetAlignment;
 property AllowGrayed: boolean read FAllowGrayed write SetAllowGrayed;
 property Anchors;
 property BiDiMode;
 property Caption: string read FCaption write SetCaption;
 property CheckBoxType: TType read FType write SetType;
 property Checked: boolean read FChecked write SetChecked;
 property Color: TColor read FColor write SetColor;
 property Constraints;
 //property Ctrl3D;
 property Cursor;
 property DragCursor;
 property DragKind;
 property DragMode;
 property Enabled;
 property Font: TFont read FFont write SetFont;
 //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 SetState;
 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
 SetChecked(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.SetAlignment(A: TAlignment);
begin
 if A <> FAlignment then
 begin
 FAlignment := A;
 Invalidate;
 end;
end;
procedure TCheckBoxX.SetType(T: TType);
begin
 if FType <> T then
 begin
 FType := T;
 Invalidate;
 end;
end;
procedure TCheckBoxX.SetFont(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
 SetChecked(not FChecked); // Изменяем состояние
 FMouseState := msMouseUp;
end;
procedure TCheckBoxX.SetAllowGrayed(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.SetState(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.SetColor(C: TColor);
begin
 if FColor <> C then
 begin
 FColor := C;
 Invalidate;
 end;
end;
procedure TCheckBoxX.SetCaption(S: string);
begin
 if FCaption <> S then
 begin
 FCaption := S;
 Invalidate;
 end;
end;
procedure TCheckBoxX.SetChecked(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.
Source: Взято из http://forum.sources.ru
ID: 01265