TLsWndMethod =
procedure(
var Message: TMessage)
of object;
TLsLabel =
class(TCustomControl)
private
FControl : TWincontrol;
FLsWndMethod : TLsWndMethod;
DieRegion : HRGN;
// ...
protected
// ...
procedure Paint;
override;
procedure WMPaint(
var Message: TWMPaint);
message WM_PAINT;
procedure SetControl(Value: TLsParent);
procedure Notification(AComponent : TComponent;
Operation : TOperation);
override;
// ...
procedure MyWndProc(
Var Message : TMessage);
procedure MakeRegion(RepaintIt : Boolean);
public
constructor create(AOwner : TComponent);
override;
destructor destroy;
override;
published
property Associate : TLsParent
read FControl
write SetControl;
// ...
end;
implementation
constructor TLsLabel.Create(AOwner : TComponent);
begin
inherited create(AOwner);
if (AOwner
is TWincontrol)
then Parent := TWincontrol(AOwner);
FLsWndMethod :=
nil;
FControl :=
nil;
SP;
// Setzt Array "DiePunkte" in Abhängigkeit der Position am
// Verlinkten Control - hat 6 Punkte, sieht etwa so aus:
// 1| --------------------------------------------------# 6
// | ############################### 5
// | LabelText # 4
// | #
// | #
// 2 ################## 3
DieRegion:= CreatePolygonRgn(DiePunkte,6,ALTERNATE);
SetWindowRgn(
Handle, DieRegion, True);
OldW := self.Width;
OldH := self.Height;
IsSetting := False;
end;
destructor TLsLabel.Destroy;
begin
FCaptionFont.Free;
IF Assigned(FControl)
and Assigned(FLsWndMethod)
then TWinControl(FControl).WindowProc := FLsWndMethod;
FLsWndMethod :=
nil;
inherited destroy;
end;
procedure TLsLabel.SetControl(Value: TLsParent);
var i : integer;
ControlFound : Boolean;
AlterAssociate : TLsParent;
AltesControl : TWincontrol;
AlteWinMet : TLsWndMethod;
begin
if Value <> FControl
then
begin
if not Assigned(Value)
then
begin
if Assigned(FControl)
then
begin
TWinControl(FControl).WindowProc := FLsWndMethod;
FLsWndMethod :=
nil;
end;
FControl := Value;
FCaption := '
Bin Einsam!';
end else
begin
if Assigned(FControl)
then begin
TWinControl(FControl).WindowProc := FLsWndMethod;
FLsWndMethod :=
nil;
end;
FControl := Value;
Parent := FControl.Parent;
Left := FControl.Left;
Width := FControl.Width;
Top := FControl.Top+FControl.Height-2;
// wie gesagt,
// es ragt hinein
FLsWndMethod := TWincontrol(FControl).WindowProc;
TWincontrol(FControl).WindowProc := MyWndProc;
TWinControl(FControl).SendToBack;
end;
end;
if Assigned(FControl)
then Paint;
end;
procedure TLsLabel.MyWndProc(
Var Message : TMessage);
begin
if Assigned(FControl)
and not
(csDestroying
in TWincontrol(FControl).ComponentState)
and not
(csDestroying
in self.ComponentState)
then
begin
if (
Message.Msg
in [WM_PAINT,
WM_SHOWWINDOW,
WM_WINDOWPOSCHANGED,
WM_SIZE,
WM_MOVE,
WM_WINDOWPOSCHANGING])
and not
IsSetting
then
begin
IsSetting := True;
Left := FControl.Left;
Width := FControl.Width;
Top := FControl.Top+FControl.Height-2;
end;
if Assigned(FLsWndMethod)
then FLsWndMethod(
Message);
IsSetting := False;
Invalidate;
end;
end;
procedure TLsLabel.WMPaint(
var Message: TWMPaint);
begin
if not IsSetting
then
begin
if (self.Width <> OldW)
or (self.Height <> OldH)
then
begin
OldW := self.Width;
OldH := self.Height;
IsSetting := True;
MakeRegion(True);
// löscht das RegionObjekt,
// und setzt neue Region
// ruft Paint auf
IsSetting := False;
end;
end;
if Message.Msg <> WM_WINDOWPOSCHANGED
then inherited;
Paint;
end;
procedure TLsLabel.MakeRegion(RepaintIt : Boolean);
begin
DeleteObject(DieRegion);
if FCaptionVisible
then
begin
SP;
// setzt DiePunkte neu
DieRegion:= CreatePolygonRgn(DiePunkte,6,ALTERNATE);
SetWindowRgn(
Handle, DieRegion, RepaintIt);
end else
begin
DieRegion:= CreateRectRgn(0,0,Width,Height);
SetWindowRgn(
Handle, DieRegion, RepaintIt);
end;
Paint;
end;
procedure TLsLabel.Notification(AComponent : TComponent; Operation : TOperation);
begin
if ( (FControl <>
nil)
and
(AComponent = TComponent(FControl))
and
(Operation = opRemove))
then
begin
FControl :=
nil;
if not (csDestroying
in Componentstate)
then
begin
FCaption := '
Bin Einsam!';
Paint;
end;
end;
end;
procedure TLsLabel.Paint;
begin
ExistControl := Assigned(FControl);
inherited paint;
if HasParent
then
begin
Canvas.Brush.Color := FCaptionColorBack;
Canvas.FillRect(GR(0));
// GR liefert TRect
Canvas.Pen.Style := psClear;
Canvas.Pen.Color := GF(0);
//GF liefert TColor
Canvas.MoveTo(GP('
A').x,GP('
A').y);
//GP liefert TPoint
Canvas.LineTo(GP('
B').x,GP('
B').y);
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := FCaptionColorFront;
Canvas.Pen.Color := FCaptionColorFront;
Canvas.TextRect(GR(1),GP('
I').x,GP('
I').y,FCaption);
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := GF(1);
Canvas.MoveTo(GP('
C').x,GP('
C').y);
Canvas.LineTo(GP('
D').x,GP('
D').y);
//... usw. Malen halt - nix sonst
end;
end;