Нужен TShape нестандарной формы, как это сделать?

← →
reonid (2002-01-31 12:54) [1]

Приблизительно так:

unit MyShapes;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;

type
TMyShape = class(TShape)
private
FAngle: Integer;
procedure SetAngle(const Value: Integer);
protected
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
public
procedure Paint; override;
function Contain(X, Y: Integer): Boolean;
published
property Angle: Integer read FAngle write SetAngle;
end;

procedure Register;

implementation

uses
Math;

{ TMyShape }

procedure TMyShape.CMHitTest(var Message: TCMHitTest);
begin
with Message do Result := Integer( Contain(XPos, YPos) );
end;

function TMyShape.Contain(X, Y: Integer): Boolean;
var DX, DY: Integer;
tg, WW, HH, xx, yy, CenterX, CenterY, AngleRad: Double;
begin
if FAngle = 0 then Result := True
else with Canvas do
begin
AngleRad := FAngle/57.2957795130;
if FAngle < 0 then AngleRad := Pi/2 + AngleRad;
tg := Tan(AngleRad);
DY := Round( (Height - tg*Width)/(1 - tg*tg) );
DX := Round(DY*tg);

HH := DX/Sin(AngleRad);
WW := (Height - DY)/Sin(AngleRad);
CenterX := Width/2;
CenterY := Height/2;
xx := (X-CenterX)*Cos(-AngleRad) + (Y-CenterY)*Sin(-AngleRad);
yy := (Y-CenterY)*Cos(-AngleRad) - (X-CenterX)*Sin(-AngleRad);

if (DX > Width)or(DY > Height)or(DX <= 0)or(DY <= 0)then
begin
Result := (X >= 0)and(Y >= 0)and(X <= Width)and(Y <= Height);
Exit;
end;

if (Abs(xx) < WW/2)and(Abs(yy) < HH/2) then
Result := True
else
Result := False;
end;
end;

procedure TMyShape.Paint;
var DX, DY: Integer;
AngleRad, tg: Double;
begin
if FAngle = 0 then inherited Paint
else with Canvas do
begin
AngleRad := FAngle/57.2957795130;
if FAngle < 0 then AngleRad := Pi/2 + AngleRad;
tg := Tan(AngleRad);
DY := Round( (Height - tg*Width)/(1 - tg*tg) );
DX := Round(DY*tg);

Pen := Self.Pen;
Brush := Self.Brush;

if (DX > Width)or(DY > Height)or(DX <= 0)or(DY <= 0)then
begin
TextRect(ClientRect, 0, 0, "Wrong angle");
// note: 45 degree is allowed only for case Width = Height
Exit;
end;

Polygon([Point(DX, Height), Point(0, Height - DY),
Point(Width - DX, 0), Point(Width, DY)]);
end;
end;

procedure Register;
begin
RegisterComponents("Test", [TMyShape]);
end;

procedure TMyShape.SetAngle(const Value: Integer);
begin
if FAngle <> Value then
if Abs(Value) < 90 then
begin
FAngle := Value;
Invalidate;
end;
end;

end.

Нужен TShape нестандарной формы, как это сделать? Найти похожие ветки