Видоизменяем чекбоксы в 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