<div dir="ltr"><div class="gmail_extra"><div class="gmail_quote">2013/12/26 Howard Page-Clark <span dir="ltr"><<a href="mailto:hdpc@talktalk.net" target="_blank">hdpc@talktalk.net</a>></span><br><blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">
<div class="im">On 26/12/2013 12:03, Frederic Da Vitoria wrote:<br>
Should I<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">
forget about deriving TShape and should I directly modify TShape's code?<br>
</blockquote>
<br></div>
For a project that needed something similar I found that TShape with its fixed TShapeType enumeration was too inflexible (though it is Delphi-compatible, hence its presence).<br>
Trying to stuff too much shape-drawing code variety into one gloriously polymorphic control becomes increasingly complex and difficult to maintain.<br>
I ended up writing a simple (isosceles only) triangle control which you are welcome to adapt as suits you, attached here.<br>
<br>
unit triangles;<br>
<br>
{$mode objfpc}{$H+}<br>
<br>
interface<br>
<br>
uses<br>
Classes, Controls, types, Graphics, LCLProc;<br>
<br>
type<br>
{$M+}<br>
TBaseAlign=(baBottom, baTop, baLeft, baRight);<br>
{$M+}<br>
<br>
{ TTriangle }<br>
<br>
TTriangle=class(<u></u>TGraphicControl)<br>
private<br>
FPen: TPen;<br>
FBaseAlign: TBaseAlign;<br>
FBrush: TBrush;<br>
procedure SetBrush(Value: TBrush);<br>
procedure SetPen(Value: TPen);<br>
procedure SetBaseAlign(aValue: TBaseAlign);<br>
protected<br>
class function GetControlClassDefaultSize: TSize; override;<br>
public<br>
constructor Create(TheOwner: TComponent); override;<br>
destructor Destroy; override;<br>
procedure Paint; override;<br>
procedure ParamsChanged(Sender: TObject);<br>
published<br>
property Align;<br>
property Anchors;<br>
property BaseAlign: TBaseAlign read FBaseAlign write SetBaseAlign default baBottom;<br>
property BorderSpacing;<br>
property Brush: TBrush read FBrush write SetBrush;<br>
property Constraints;<br>
property DragCursor;<br>
property DragKind;<br>
property DragMode;<br>
property Enabled;<br>
property ParentShowHint;<br>
property Pen: TPen read FPen write SetPen;<br>
property OnChangeBounds;<br>
property OnDragDrop;<br>
property OnDragOver;<br>
property OnEndDock;<br>
property OnEndDrag;<br>
property OnMouseDown;<br>
property OnMouseMove;<br>
property OnMouseUp;<br>
property OnPaint;<br>
property OnResize;<br>
property OnStartDock;<br>
property OnStartDrag;<br>
property ShowHint;<br>
property Visible;<br>
end;<br>
<br>
implementation<br>
<br>
{ TTriangle }<br>
<br>
procedure TTriangle.SetBrush(Value: TBrush);<br>
begin<br>
if Value <> Brush then<br>
FBrush.Assign(Value);<br>
end;<br>
<br>
procedure TTriangle.SetPen(Value: TPen);<br>
begin<br>
if Value <> Pen then<br>
FPen.Assign(Value);<br>
end;<br>
<br>
procedure TTriangle.SetBaseAlign(aValue: TBaseAlign);<br>
begin<br>
if aValue<>FBaseAlign then begin<br>
FBaseAlign:=aValue;<br>
ParamsChanged(Self);<br>
end;<br>
end;<br>
<br>
class function TTriangle.<u></u>GetControlClassDefaultSize: TSize;<br>
begin<br>
Result.cx:=65;<br>
Result.cy:=65;<br>
end;<br>
<br>
constructor TTriangle.Create(TheOwner: TComponent);<br>
begin<br>
inherited Create(TheOwner);<br>
with GetControlClassDefaultSize do<br>
SetInitialBounds(0, 0, CX, CY);<br>
ControlStyle := ControlStyle + [csReplicatable];<br>
FPen := TPen.Create;<br>
FPen.OnChange := @ParamsChanged;<br>
FBrush := TBrush.Create;<br>
FBrush.OnChange := @ParamsChanged;<br>
FBaseAlign:=baBottom;<br>
end;<br>
<br>
destructor TTriangle.Destroy;<br>
begin<br>
FreeThenNil(FPen);<br>
FreeThenNil(FBrush);<br>
inherited Destroy;<br>
end;<br>
<br>
procedure TTriangle.Paint;<br>
var<br>
PaintRect: TRect;<br>
P: array[1..3] of TPoint;<br>
PenInc, PenDec: Integer;<br>
<br>
procedure CalcPoints(aBaseAlign: TBaseAlign);<br>
begin<br>
case aBaseAlign of<br>
baBottom: begin P[1].x := (Width - 1) div 2;<br>
P[1].y := PenInc;<br>
P[2].x := Width - PenInc - 1;<br>
P[2].y := Height - PenInc - 1;<br>
P[3].x := PenInc;<br>
P[3].y := Height - PenInc - 1; end;<br>
baTop: begin P[3].x := (Width - 1) div 2;<br>
P[1].x := PenInc;<br>
P[2].x := Width - PenInc - 1;<br>
P[3].y := Height - PenInc - 1;<br>
P[1].y := PenInc;<br>
P[2].y := PenInc; end;<br>
baLeft: begin P[1].x := PenInc;<br>
P[1].y := PenInc;<br>
P[2].x := Width - PenInc - 1;<br>
P[2].y := (Height - 1) div 2;<br>
P[3].x := PenInc;<br>
P[3].y := Height - PenInc - 1; end;<br>
baRight: begin P[1].y := (Height - 1) div 2;<br>
P[1].x := PenInc;<br>
P[2].x := Width - PenInc - 1;<br>
P[2].y := PenInc;<br>
P[3].x := Width - PenInc - 1;<br>
P[3].y := Height - PenInc - 1; end;<br>
end;<br>
end;<br>
<br>
begin<br>
Canvas.Pen:=FPen;<br>
Canvas.Brush:=FBrush;<br>
<br>
PenInc := Pen.Width div 2;<br>
PenDec := (Pen.Width - 1) div 2;<br>
<br>
PaintRect := Rect(PenInc, PenInc, Self.Width - PenDec, Self.Height - PenDec);<br>
if PaintRect.Left = PaintRect.Right then<br>
PaintRect.Right := PaintRect.Right + 1;<br>
if PaintRect.Top = PaintRect.Bottom then<br>
PaintRect.Bottom := PaintRect.Bottom + 1;<br>
<br>
CalcPoints(FBaseAlign);<br>
Canvas.Polygon(P);<br>
<br>
inherited Paint;<br>
end;<br>
<br>
procedure TTriangle.ParamsChanged(<u></u>Sender: TObject);<br>
begin<br>
if (Parent <> nil) and (Visible or (csDesigning in ComponentState)) and<br>
Parent.HandleAllocated then<br>
Invalidate;<br>
end;<br>
<br>
end.<br>
</blockquote></div><br></div><div class="gmail_extra">Isoceles is quite enough for my needs. It should be easy to add squares, rectangles and circles (although of course I'll have the change the class' name)<br><br>
Thank you, Howard<br clear="all"></div><div class="gmail_extra"><br>-- <br>Frederic Da Vitoria<br>(davitof)<br><br>Membre de l'April - « promouvoir et défendre le logiciel libre » - <a href="http://www.april.org" target="_blank">http://www.april.org</a><br>
</div></div>