Видоизменяем чекбоксы в Delphi
Материал из DRKB
Видоизменяем чекбоксы в 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