unit
DNCommentaryButton;
interface
uses
SysUtils, Classes, Controls, Messages, Graphics, Windows, ExtCtrls;
type
TTextAligment = (caLeft, caRight, caMiddle);
TTextVAligment = (caTop, caBottom, caCentre);
TPaddingCaption =
class
(TPersistent)
private
FpcLeft, FpcRight, FpcTop, FpcBottom:
Integer
;
procedure
SetpsLeft(Value:
Integer
);
procedure
SetpsRight(Value:
Integer
);
procedure
SetpsTop(Value:
Integer
);
procedure
SetpsBottom(Value:
Integer
);
published
property
pcLeft:
Integer
read FpcLeft
write
SetpsLeft;
property
pcRight:
Integer
read FpcRight
write
SetpsRight;
property
pcTop:
Integer
read FpcTop
write
SetpsTop;
property
pcBottom:
Integer
read FpcBottom
write
SetpsBottom;
end
;
TTitle =
class
(TPersistent)
private
FFont: TFont;
FCaption:
string
;
FParent: TWinControl;
FTextAligment: TTextAligment;
FTextVAligment: TTextVAligment;
public
procedure
SetCaption(Value:
string
);
constructor
Create(AParent: TWinControl);
published
property
Font: TFont read FFont
write
FFont;
property
Caption:
string
read FCaption
write
SetCaption;
property
TextAligment: TTextAligment read FTextAligment
write
FTextAligment;
property
TextVAligment: TTextVAligment read FTextVAligment
write
FTextVAligment;
end
;
TDNCommentaryButton =
class
(TCustomControl)
private
FTitle: TTitle;
FPaddingCaption: TPaddingCaption;
protected
r: TRect;
procedure
SetTitle(Value: TTitle);
procedure
SetPaddingCaption(Value: TPaddingCaption);
public
procedure
Paint; override;
constructor
Create(AOwner: TComponent); override;
destructor
Destroy; override;
published
property
Align;
property
ParentFont;
property
ParentShowHint;
property
ShowHint;
property
Visible;
property
OnClick;
property
Title: TTitle read FTitle
write
SetTitle;
property
PaddingCaption: TPaddingCaption read FPaddingCaption
write
SetPaddingCaption;
end
;
procedure
Register;
implementation
procedure
Register;
begin
RegisterComponents(
'DNControls'
, [TDNCommentaryButton]);
end
;
constructor
TDNCommentaryButton
.
Create(AOwner: TComponent);
begin
inherited
Create(AOwner);
ControlStyle := ControlStyle + [csOpaque];
FPaddingCaption := TPaddingCaption
.
Create;
FTitle := TTitle
.
Create(Self);
end
;
destructor
TDNCommentaryButton
.
Destroy;
begin
inherited
Destroy;
end
;
procedure
TDNCommentaryButton
.
Paint;
var
X:
Integer
;
Y:
Integer
;
begin
inherited
Paint;
r := ClientRect;
SetBkMode(Canvas
.
Handle, TRANSPARENT);
Canvas
.
Font := Font;
case
FTitle
.
TextAligment
of
caLeft:
X := FPaddingCaption
.
FpcLeft;
caRight:
X := Self
.
Width - Canvas
.
TextWidth(FTitle
.
FCaption) - FPaddingCaption
.
FpcRight;
caMiddle:
X := (Width
div
2
) - (Canvas
.
TextWidth(FTitle
.
FCaption)
div
2
);
end
;
case
FTitle
.
FTextVAligment
of
caTop:
Y := FPaddingCaption
.
FpcTop;
caBottom:
Y := Self
.
Height - Canvas
.
TextHeight(FTitle
.
FCaption) - FPaddingCaption
.
FpcBottom;
caCentre:
Y := (Height
div
2
) - (Canvas
.
TextHeight(FTitle
.
FCaption)
div
2
);
end
;
Canvas
.
TextOut(X, Y, FTitle
.
Caption);
end
;
procedure
TDNCommentaryButton
.
SetPaddingCaption(Value: TPaddingCaption);
begin
FPaddingCaption := Value;
Invalidate;
end
;
procedure
TDNCommentaryButton
.
SetTitle(Value: TTitle);
begin
FTitle := Value;
Invalidate;
end
;
procedure
TPaddingCaption
.
SetpsBottom(Value:
Integer
);
begin
FpcBottom := Value;
end
;
procedure
TPaddingCaption
.
SetpsLeft(Value:
Integer
);
begin
FpcLeft := Value;
end
;
procedure
TPaddingCaption
.
SetpsRight(Value:
Integer
);
begin
FpcRight := Value;
end
;
procedure
TPaddingCaption
.
SetpsTop(Value:
Integer
);
begin
FpcTop := Value;
end
;
constructor
TTitle
.
Create(AParent: TWinControl);
begin
inherited
Create;
FParent := AParent;
end
;
procedure
TTitle
.
SetCaption(Value:
string
);
begin
FCaption := Value;
FParent
.
Invalidate;
end
;
end
.