Mega Code Archive
Tired of Delphis checkboxes
<![CDATA[
Title: Tired of Delphi's checkboxes?
Question: Tired of Delphi's checkboxes?
Answer:
{
====================================================================
This is a DELPHI 5 Visual Component
====================================================================
In WIN3.1 you have a checkbox with an "X" check. In WIN95 and WINNT
you have a checkbox with a "V" check. In Delphi's standard palette
you think you'll get a checkbox with an "X" check, but you'll get a
checkbox with a "V" check instead. Maybe Borland/Inprise didn't
update the palette bitmap going from W3.1 to W95/W98.
Anyway, this is a checkbox with an "X", or a "V", or a "o", or a
rect, or a diamond check. This component is tested under WIN95 and
WINNT. This component will be registered under "Samples". You are
allowed to alter this component. For remarks, suggestions,
improvements, enhancements please email:
M.deHaan@inn.nl
====================================================================
Explanation
====================================================================
X = cross
V = mark
o = bullet
+-+
|W| = rect
+-+
/\
= diamond
\/
(W = means filled)
====================================================================
Features of this checkbox
====================================================================
You'll find many checkboxes on the web. Try them. You will find out
that when you put more than one of these checkboxes, on a form,
together with some "Delphi checkboxes", the focus rectangle will
not work properly, if there is one. All those checkboxes didn't
implement a WM_KILLFOCUS message interceptor. This checkbox does.
====================================================================
Functionality
====================================================================
The functionality of this CheckBoxX slightly differs from Delphi's
TCheckBox. I thought this functionality makes a little bit more
sense. But you may alter the functionality, if you disagree with me.
The slightly altered functionality regards the properties:
"AllowGrayed", "Checked" and "State".
====================================================================
30-08-00
Keystrokes implemented
(Tab, Spacebar)
====================================================================
}
Unit CheckBoxX;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
Const
{ Other constants }
fRBoxWidth : Integer = 13; // Width of rectangular checkbox
fRBoxHeight : Integer = 13; // Height of rectangular checkbox
Type
TState = (cbUnchecked,cbChecked,cbGrayed); // The same
// as in Delphi
TType = (cbCross,cbMark,cbBullet,cbDiamond,cbRect); // Added
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; // top of text
fTextLeft : Integer; // left of text
fBoxTop : Integer; // top of box
fBoxLeft : Integer; // left of box
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; // Yes, this removes the focus rect!
Procedure WMSetFocus(var Message : TWMSetFocus);
Message WM_SETFOCUS; // If you are using the TAB or
// Shift-Tab key
Procedure KeyDown(var Key : Word; Shift : TShiftState); override;
// Interception of KeyDown
Procedure KeyUp(var Key : Word; Shift : TShiftState); override;
// Interception of KeyUp
Public
{ Public declarations }
// If you put Create and Destroy under protected,
// Delphi complains about that.
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Published
{ Published declarations }
{ --- Properties --- }
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; // Set focus to this component
// Windows sends a WM_KILLFOCUS message to all the
// other components.
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); // Change the check
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; // Remove the focus rectangle of all the components,
// which doesn't have the focus.
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
// The MouseDown procedure is only called when the mouse
// goes down WITHIN the control, so we don't have to check
// the X and Y values.
inherited MouseDown(Button, Shift, X, Y);
fMouseState := msMouseDown;
If fState cbGrayed then
Begin
SetFocus; // Set focus to this component
// Windows sends a WM_KILLFOCUS message to all the
// other components.
fFocus := True;
Invalidate;
End;
End;
{-------------------------------------------------------------------}
procedure TCheckBoxX.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
Begin
// The MouseUp procedure is only called when the mouse
// goes up WITHIN the control, so we don't have to check
// the X and Y values.
inherited MouseUp(Button, Shift, X, Y);
If fState cbGrayed then
fSetChecked(not fChecked); // Change the check
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;
// Write the caption
Canvas.Pen.Color := fFont.Color;
Canvas.Brush.Color := fColor;
Canvas.TextOut(fTextLeft,fTextTop,fCaption);
// Draw the focus rectangle
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;
// Make the box clBtnFace when the mouse is down
// just like the "standard" CheckBox
If fMouseState = msMouseDown then
Canvas.Brush.Color := clBtnFace;
Canvas.FillRect(Rect(fBoxLeft + 2,
fBoxTop + 2,
fBoxLeft + fRBoxWidth - 2,
fBoxTop + fRBoxHeight - 2));
// Draw the rectangular checkbox
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);
// Now it should be exactly the same as the Delphi checkbox
If fChecked then
Begin
Canvas.Pen.Color := clBlack;
Canvas.Brush.Color := clBlack;
// Paint the rectangle
If fType = cbRect then
Begin
Canvas.FillRect(Rect(fBoxLeft + 4,fBoxTop + 4,
fBoxLeft + fRBoxWidth - 4,fBoxTop + fRBoxHeight - 4));
End;
// Paint the bullet
If fType = cbBullet then
Begin
Canvas.Ellipse(fBoxLeft + 4,fBoxTop + 4,
fBoxLeft + fRBoxWidth - 4,fBoxTop + fRBoxHeight - 4);
End;
// Paint the cross
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;
// Paint the mark
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;
// Paint the diamond
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.
{===================================================================}
]]>