Исходники.RU - Информационный сервер для программистов: исходники со всего света.

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

В WIN3.1 чекбоксы заполняются символом "X". В WIN95 и WINNT - символом "V". В тандартной палитре Delphi чекбоксы заполняются символом "X". Спрашивается - почему фирма Borland/Inprise не исправила значёк чекбокса для W95/W98 ?. Данный пример позволяет заполнять чекбокс такими значками как: "X", "V", "o", "закрашенным прямоугольником", или бриллиантиком.

Пример тестировался под WIN95 и WINNT.

Совместимость: Delphi 5.x (или выше)

Собственно сам исходничек:

{
====================================================================
                          Обозначения
====================================================================
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; // это убирает контур фокуса!
    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 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.
{===================================================================}