Delphi World - Видоизменяем чекбоксы в Delphi
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Видоизменяем чекбоксы в Delphi

Автор: Maarten de Haan

В 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 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 World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования