Cool-Checkbox


            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.
VCL Delphi
