Mega Code Archive
Cool Checkbox
<![CDATA[
Title: Cool Checkbox
Question: Checkbox with extra features
Answer:
{*********************************************************************}
I think the component should be cool for some of you...
Here is the extra features :
AutoSizeCheckMark : When this property is set to TRUE, the size of the
checkbox will fit the font size.
CheckBoxType : 5 different looks are available when the checked property
is checked: Cross, Mark, Bullet, Diamond and Rect
CheckMarkColor : You can set the color of the check mark.
{*********************************************************************}
unit RVCheckBox;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TCheckBoxState = (cbUnchecked, cbChecked, cbGrayed);
TType = (cbCross, cbMark, cbBullet, cbDiamond, cbRect);
TMouseState = (msMouseUp, msMouseDown);
TAlignment = (taRightJustify, taLeftJustify);
TRVCustomCheckBox = class(TCustomControl)
private
fRBoxWidth : Integer; // Width du "CheckBox" rectangulaire
fRBoxHeight : Integer; // Height du "CheckBox" rectangulaire
fChecked : Boolean;
fCaption : String;
fCtl3D : Boolean;
fColor : TColor;
fFont : TFont;
fAllowGrayed : Boolean;
fFocus : Boolean;
fType : TType;
fMouseState : TMouseState;
fAlignment : TAlignment;
fTextTop : Integer;
fTextLeft : Integer;
fBoxTop : Integer;
fBoxLeft : Integer;
fState : TCheckBoxState;
fCheckMarkColor : TColor;
fAutoSizeCheckMark: Boolean;
procedure fSetAutoSizeCheckMark(const Value: Boolean);
procedure fSetChecked(const Value: Boolean);
procedure fSetCaption(const Value: String);
procedure fSetColor(const Value: TColor);
procedure fSetCheckMarkColor(const Value: TColor);
procedure fSetCtl3D(const Value: Boolean);
procedure fSetState(const Value: TCheckBoxState);
procedure fSetFont(const Value: TFont);
procedure fSetAllowGrayed(const Value: Boolean);
procedure fSetType(const Value: TType);
procedure fSetAlignment(const Value: TAlignment);
protected
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;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Action;
property Alignment: TAlignment read fAlignment write fSetAlignment;
property AllowGrayed: Boolean read fAllowGrayed write fSetAllowGrayed;
property Anchors;
property AutoSizeCheckMark: Boolean read fAutoSizeCheckMark write fSetAutoSizeCheckMark;
property BiDiMode;
property Caption: String read fCaption write fSetCaption;
property CheckBoxType: TType read fType write fSetType;
property CheckMarkColor: TColor read fCheckMarkColor write fSetCheckMarkColor;
property Ctl3D: Boolean read fCtl3D write fSetCtl3D;
property Color: TColor read fColor write fSetColor;
property Constraints;
property Cursor;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font: TFont read fFont write fSetFont;
property HelpContext;
property Hint;
property Left;
property Name;
property ParentColor;
property ParentFont;
property ParentShowHint;
property ShowHint;
property TabOrder;
property TabStop;
property Tag;
property Top;
property Visible;
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;
TRVCheckBox = class(TRVCustomCheckBox)
private
{private declarations}
protected
{protected declarations}
public
{public declarations}
published
property Checked: Boolean read fChecked write fSetChecked;
property State: TCheckBoxState read fState write fSetState;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Rendez-vous', [TRVCheckBox]);
end;
{ TRVCustomCheckBox }
constructor TRVCustomCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 17;
Width := 97;
fRBoxWidth := LoWord(GetMenuCheckMarkDimensions);
fRBoxHeight := HiWord(GetMenuCheckMarkDimensions);
fAutoSizeCheckMark := False;
fChecked := False;
fCheckMarkColor := clBlack;
fColor := clBtnFace;
fCtl3D := True;
fState := cbUnChecked;
fFont := inherited Font;
fAllowGrayed := False;
fFocus := False;
fMouseState := msMouseUp;
fAlignment := taRightJustify;
TabStop := True; //Dsol
FCaption := Name;
end;
destructor TRVCustomCheckBox.Destroy;
begin
inherited Destroy;
end;
procedure TRVCustomCheckBox.fSetAlignment(const Value: TAlignment);
begin
if Value fAlignment then
begin
fAlignment := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetAllowGrayed(const Value: Boolean);
begin
if fAllowGrayed Value then
begin
fAllowGrayed := Value;
if not fAllowGrayed then
if fState = cbGrayed then
begin
if fChecked then fState := cbChecked
else fState := cbUnChecked;
end;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetAutoSizeCheckMark(const Value: Boolean);
begin
if fAutoSizeCheckMark Value then
begin
fAutoSizeCheckMark := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetCaption(const Value: String);
begin
if fCaption Value then
begin
fCaption := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetChecked(const Value: Boolean);
begin
if fChecked Value then
begin
fChecked := Value;
if fState cbGrayed then
begin
if fChecked then fState := cbChecked
else fState := cbUnChecked;
end;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetCheckMarkColor(const Value: TColor);
begin
if fCheckMarkColor Value then
begin
fCheckMarkColor := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetColor(const Value: TColor);
begin
if fColor Value then
begin
fColor := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetCtl3D(const Value: Boolean);
begin
if Value fCtl3D then
begin
fCtl3D := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetFont(const Value: TFont);
var
FontChanged: Boolean;
begin
FontChanged := False;
if fFont.Style Value.Style then
begin
fFont.Style := Value.Style;
FontChanged := True;
end;
if fFont.CharSet Value.Charset then
begin
fFont.Charset := Value.Charset;
FontChanged := True;
end;
if fFont.Size Value.Size then
begin
fFont.Size := Value.Size;
FontChanged := True;
end;
if fFont.Name Value.Name then
begin
fFont.Name := Value.Name;
FontChanged := True;
end;
if fFont.Color Value.Color then
begin
fFont.Color := Value.Color;
FontChanged := True;
end;
if FontChanged then
begin
Canvas.Font.Assign(fFont);
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetState(const Value: TCheckBoxState);
begin
if fState Value then
begin
fState := Value;
if fState = cbChecked then fChecked := True;
if fState = cbGrayed then fAllowGrayed := True;
if fState = cbUnChecked then fChecked := False;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.fSetType(const Value: TType);
begin
if fType Value then
begin
fType := Value;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.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;
fFocus := True;
Invalidate;
end;
end;
inherited KeyDown(Key, Shift);
end;
procedure TRVCustomCheckBox.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 TRVCustomCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
fMouseState := msMouseDown;
if fState cbGrayed then
begin
SetFocus;
fFocus := True;
Invalidate;
end;
end;
procedure TRVCustomCheckBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if fState cbGrayed then fSetChecked(not fChecked);
fMouseState := msMouseUp;
end;
procedure TRVCustomCheckBox.Paint;
var
I : Integer;
fTextWidth : Integer;
fTextHeight: Integer;
NewRect : TRect;
PtDiamond : array[0..3] of TPoint;
begin
Canvas.Font.Name := fFont.Name;
Canvas.Font.Size := fFont.Size;
Canvas.Font.Style := fFont.Style;
Canvas.Font.Color := fFont.Color;
Canvas.Font.Charset := fFont.CharSet;
if fAutoSizeCheckMark then
begin
fRBoxWidth := Canvas.TextHeight('Qq');
fRBoxHeight := Canvas.TextHeight('Qq');
if not Odd(fRBoxWidth) then
begin
fRBoxWidth := fRBoxWidth - 1;
fRBoxHeight := fRBoxHeight - 1;
end;
end
else
begin
fRBoxWidth := LoWord(GetMenuCheckMarkDimensions);
fRBoxHeight := HiWord(GetMenuCheckMarkDimensions);
end;
fTextWidth := Canvas.TextWidth(fCaption);
fTextHeight := Canvas.TextHeight('Qq');
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;
end;
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;
if fMouseState = msMouseDown then Canvas.Brush.Color := clBtnFace;
Canvas.FillRect(Rect(fBoxLeft + 2,
fBoxTop + 2,
fBoxLeft + fRBoxWidth - 2,
fBoxTop + fRBoxHeight - 2));
if Ctl3D then
begin
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);
end
else
begin
Canvas.Pen.Color := clBlack;
Canvas.Rectangle(fBoxLeft, fBoxTop, fBoxLeft + fRBoxWidth, fBoxTop + fRBoxHeight);
end;
if fChecked then
begin
Canvas.Pen.Color := fCheckMarkColor;
Canvas.Brush.Color := fCheckMarkColor;
// Paint le rectangle
if fType = cbRect then
Canvas.FillRect(Rect(fBoxLeft + 4, fBoxTop + 4, fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4));
// Paint le boulet
if fType = cbBullet then
Canvas.Ellipse(fBoxLeft + 4, fBoxTop + 4, fBoxLeft + fRBoxWidth - 4, fBoxTop + fRBoxHeight - 4);
// Paint le X
if fType = cbCross then
begin
{Right - top 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 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);
Canvas.MoveTo(fBoxLeft + 4, fBoxTop + 3);
Canvas.LineTo(fBoxLeft + fRBoxWidth - 3, fBoxTop + fRBoxHeight - 4);
end;
// Paint la marque
if fType = cbMark then
begin
for I := 0 to 2 do
begin
Canvas.MoveTo(fBoxLeft + Round(fRBoxWidth * 0.23), fBoxTop + Round(fRBoxHeight * 0.39) + I);
Canvas.LineTo(fBoxLeft + Round(fRBoxWidth * 0.46), fBoxTop + Round(fRBoxHeight * 0.62) + I);
end;
for I := 0 to 2 do
begin
Canvas.MoveTo(fBoxLeft + Round(fRBoxWidth * 0.46), fBoxTop + Round(fRBoxHeight * 0.46) + I);
Canvas.LineTo(fBoxLeft + Round(fRBoxWidth * 0.77), fBoxTop + Round(fRBoxHeight * 0.15) + I);
end;
end;
// Paint the diamond
if fType = cbDiamond then
begin
NewRect := Rect(fBoxLeft + 4, fBoxTop + 4, fBoxLeft + fRBoxWidth - 5, fBoxTop + fRBoxHeight - 5);
PtDiamond[0].X := NewRect.Left + ((NewRect.Right - NewRect.Left) div 2);
PtDiamond[0].Y := NewRect.Top;
PtDiamond[1].X := NewRect.Right;
PtDiamond[1].Y := NewRect.Top + ((NewRect.Bottom - NewRect.Top) div 2);
PtDiamond[2].X := NewRect.Left + ((NewRect.Right - NewRect.Left) div 2);
PtDiamond[2].Y := NewRect.Bottom;
PtDiamond[3].X := NewRect.Left;
PtDiamond[3].Y := NewRect.Top + ((NewRect.Bottom - NewRect.Top) div 2);
Canvas.Polygon(PtDiamond);
end;
end;
end;
procedure TRVCustomCheckBox.WMKillFocus(var Message: TWMKillFocus);
begin
fFocus := False;
Invalidate;
end;
procedure TRVCustomCheckBox.WMSetFocus(var Message: TWMSetFocus);
begin
fFocus := True;
Invalidate;
end;
end.
]]>