{
==========================================
Обозначения
==========================================
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.
|
Видоизменяем чекбоксы в Delphi
