Полезное для программистов:

Фриланс
Новости
Статьи
   
Рубрики:


Видоизменяем чекбоксы в 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 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.
{===================================================================}
Автор: ИСХОДНИКИ.RU
Сайт: http://www.sources.ru






Просмотров: 2351

 

 

Новые статьи:


Популярные:
  1. Как сделать цикличным проигрывание MIDI-файла?
  2. Создание AVI файла из рисунков
  3. Как устройство "отключить в данной конфигурации"?
  4. Kто в данный момент присоединен через Сеть?
  5. Как узнать количество доступной памяти?
  6. Как реализовать в RichEdit разноцветный текст?
  7. Как скрыть свое приложение от ProcessViewer
  8. Как программно нажать/скрыть/показ кнопку "Start"?
  9. Модуль работы с ресурсами в PE файлах
10. Функции вызова диалоговых окон выбора
11. Проверка граматики средствами Word'а из Delphi.
12. Модуль для упрощенного вызова сообщений
13. Функции для записи и чтение своих данных в, ЕХЕ- файле
14. Рекурсивный просмотр директорий
15. Network Traffic Monitor
16. Разные модули
17. Универсальная функция для обращения к любым экспортируем функциям DLL
18. Библиотека от VladS
19. Протектор для UPX'а
20. Еще об ICQ, сообщения по контакт листу?
21. Использование открытых интерфейсов
22. Теория и практика использования RTTI
23. Работа с TApplication
24. Примеры использования Drag and Drop для различных визуальных компонентов
25. Что такое порт? Правила для работы с портами
26. Симфония на клавиатуре
27. Загрузка DLL
28. Исправление автоинкремента
29. Взаимодействие с чужими окнами
30. Проверить дубляжи в столбце


 

 

 
 
На главную