Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 1 марта!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



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




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS