unit UCKBM;
interface
uses
StdCtrls, ExtCtrls, Classes, Types, Controls, Messages;
type
TCheckBoxMulti =
class(TCustomPanel)
private
FIMG: TImage;
// Box
FCaptionText: TLabel;
// Text
FFucusRect: TRect;
// Focus-Rahmen
FState: Integer;
FEnabled: Boolean;
FCaption:
string;
FFocus: Boolean;
procedure WMKillFocus(
var Message: TWMKillFocus);
message WM_KILLFOCUS;
procedure WMSetFocus(
var Message: TWMSetFocus);
message WM_SETFOCUS;
protected
function GetEnabled: Boolean;
override;
function GetCaption:
string;
procedure Paint;
override;
procedure SetState(
const Value: Integer);
procedure SetEnabled(Value: Boolean);
override;
procedure SetCaption(
const Value:
string);
procedure SetCheck(
const Value: Integer);
procedure ChangeChecked;
procedure ResizeCaptionText;
procedure KeyPress(
var Key:Char);
override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure SubClick(Sender: TObject);
procedure SubMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure SubMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure SubMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
public
procedure SetFocus;
override;
constructor Create(AOwner:TComponent);
override;
destructor Destroy;
override;
published
property Enabled: Boolean
read GetEnabled
write SetEnabled
default True;
property Caption:
string read GetCaption
write SetCaption;
property State: Integer
read FState
write SetState;
end;
implementation
uses
Graphics;
{ TCheckBoxMulti }
constructor TCheckBoxMulti.Create(AOwner: TComponent);
var BorderBMP: TBitmap;
begin
inherited Create(AOwner);
Height:= 17;
Width:= 97;
BevelOuter:= bvNone;
FIMG:= TImage.Create(Self);
FIMG.Parent:= Self;
FIMG.Top:= Top+2;
FIMG.Height:= 13;
FIMG.Left:= 0;
FIMG.Width:= 13;
FIMG.OnMouseDown:= SubMouseDown;
FIMG.OnMouseMove:= SubMouseMove;
FIMG.OnMouseUp:= SubMouseUp;
FIMG.OnClick:= SubClick;
FCaptionText:= TLabel.Create(Self);
FCaptionText.Parent:= Self;
FCaptionText.Top:= 1;
FCaptionText.Left:= 18;
FCaptionText.Canvas.Pen.Style:= psClear;
FCaptionText.Canvas.Brush.Style:= bsClear;
FCaptionText.OnMouseDown:= SubMouseDown;
FCaptionText.OnMouseMove:= SubMouseMove;
FCaptionText.OnMouseUp:= SubMouseUp;
FCaptionText.OnClick:= SubClick;
ResizeCaptionText;
BorderBMP:= TBitmap.Create;
try
BorderBMP.Width:= 13;
BorderBMP.Height:= 13;
BorderBMP.Canvas.Brush.Style:= bsSolid;
BorderBMP.Canvas.Brush.Color:= clWhite;
BorderBMP.Canvas.FillRect(Rect(0,0,BorderBMP.Width,BorderBMP.Height));
BorderBMP.Canvas.Pen.Style:= psSolid;
BorderBMP.Canvas.Pen.Color:= clBtnShadow;
BorderBMP.Canvas.MoveTo(0,11);
BorderBMP.Canvas.LineTo(0,0);
BorderBMP.Canvas.LineTo(12,0);
BorderBMP.Canvas.Pen.Color:= clBtnFace;
BorderBMP.Canvas.MoveTo(11,1);
BorderBMP.Canvas.LineTo(11,11);
BorderBMP.Canvas.LineTo(0,11);
BorderBMP.Canvas.Pen.Color:= cl3DDkShadow;
BorderBMP.Canvas.MoveTo(1,10);
BorderBMP.Canvas.LineTo(1,1);
BorderBMP.Canvas.LineTo(11,1);
FIMG.Picture.Bitmap.Assign(BorderBMP);
finally
BorderBMP.Free;
end;
Caption:= '
';
TabStop:= True;
FEnabled:= True;
FFocus:= False;
FState:= 0;
ChangeChecked;
end;
destructor TCheckBoxMulti.Destroy;
begin
FIMG.Free;
inherited Destroy;
end;
procedure TCheckBoxMulti.ChangeChecked;
var x: Integer;
begin
if FEnabled
then FIMG.Picture.Bitmap.Canvas.Brush.Color:= clWhite
else FIMG.Picture.Bitmap.Canvas.Brush.Color:= clBtnFace;
FIMG.Picture.Bitmap.Canvas.Brush.Style:= bsSolid;
FIMG.Picture.Bitmap.Canvas.FillRect(Rect(2,2,FIMG.Picture.Bitmap.Width-2,FIMG.Picture.Bitmap.Height-2));
if FState<>0
then begin
if FEnabled
then begin
if FState=1
then FIMG.Picture.Bitmap.Canvas.Pen.Color:= clBlack
else FIMG.Picture.Bitmap.Canvas.Pen.Color:= clRed;
end
else begin
if FState=1
then FIMG.Picture.Bitmap.Canvas.Pen.Color:= clBtnShadow
else FIMG.Picture.Bitmap.Canvas.Pen.Color:= clMaroon;
end;
FIMG.Picture.Bitmap.Canvas.Pen.Style:= psSolid;
for x:= 0
to 2
do begin
FIMG.Picture.Bitmap.Canvas.MoveTo(3,5+x);
FIMG.Picture.Bitmap.Canvas.LineTo(5,7+x);
FIMG.Picture.Bitmap.Canvas.LineTo(10,2+x);
end;
end;
end;
procedure TCheckBoxMulti.SetState(
const Value: Integer);
var i: Integer;
begin
if Value=0
then i:= 0
else if Value>0
then i:= 1
else i:= -1;
SetCheck(i);
end;
procedure TCheckBoxMulti.SetEnabled(Value: Boolean);
begin
if FEnabled<>Value
then begin
FEnabled:= Value;
inherited Enabled:= Value;
FCaptionText.Enabled:= Value;
ChangeChecked;
end;
end;
function TCheckBoxMulti.GetEnabled: Boolean;
begin
Result:= FEnabled;
end;
procedure TCheckBoxMulti.SetCaption(
const Value:
string);
begin
if FCaption<>Value
then begin
FCaption:= Value;
FCaptionText.Caption:= FCaption;
ResizeCaptionText;
end;
end;
function TCheckBoxMulti.GetCaption:
string;
begin
Result:= FCaption;
end;
procedure TCheckBoxMulti.ResizeCaptionText;
begin
FFucusRect.Top:= 0;
FFucusRect.Left:= FCaptionText.Left-1;
FFucusRect.Bottom:= FCaptionText.Height+3;
FFucusRect.Right:= FCaptionText.Left+FCaptionText.Width+1;
if FFucusRect.Right>Width-FCaptionText.Left
then
FFucusRect.Right:= Width-FCaptionText.Left;
end;
procedure TCheckBoxMulti.SetFocus;
begin
inherited;
FFocus:= True;
end;
procedure TCheckBoxMulti.SetCheck(
const Value: Integer);
begin
if FState<>Value
then begin
FState:= Value;
if (FState<-1)
or (FState>1)
then FState:= 0;
ChangeChecked;
end;
end;
procedure TCheckBoxMulti.KeyPress(
var Key: Char);
var i: Integer;
begin
inherited;
if Key='
'
then begin
i:= FState+1;
if i=2
then i:= -1;
SetCheck(i);
end;
end;
procedure TCheckBoxMulti.Paint;
begin
inherited;
if Focused
then begin
Canvas.Brush.Color:= clWhite;
Canvas.DrawFocusRect(FFucusRect);
FFocus:= True;
end;
end;
procedure TCheckBoxMulti.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
if FEnabled
then begin
if Button=mbRight
then begin
SetCheck(FState-1);
Click;
end
else if Button=mbLeft
then SetCheck(FState+1);
SetFocus;
end;
end;
procedure TCheckBoxMulti.SubClick(Sender: TObject);
begin
Click;
end;
procedure TCheckBoxMulti.SubMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseDown(Button,Shift,X+(Sender
as TControl).Left,Y+(Sender
as TControl).Top);
end;
procedure TCheckBoxMulti.SubMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
MouseMove(Shift,X+(Sender
as TControl).Left,Y+(Sender
as TControl).Top);
end;
procedure TCheckBoxMulti.SubMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseUp(Button,Shift,X+(Sender
as TControl).Left,Y+(Sender
as TControl).Top);
end;
procedure TCheckBoxMulti.WMKillFocus(
var Message: TWMKillFocus);
begin
inherited;
if FFocus
then begin
Canvas.DrawFocusRect(FFucusRect);
FFocus:= False;
end;
end;
procedure TCheckBoxMulti.WMSetFocus(
var Message: TWMSetFocus);
begin
inherited;
if Focused
then begin
Canvas.Brush.Color:= clWhite;
Canvas.DrawFocusRect(FFucusRect);
FFocus:= True;
end;
end;
end.