On 26/12/2013 12:03, Frederic Da Vitoria wrote:
Should I
forget about deriving TShape and should I directly modify TShape's code?
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).
Trying to stuff too much shape-drawing code variety into one gloriously
polymorphic control becomes increasingly complex and difficult to maintain.
I ended up writing a simple (isosceles only) triangle control which you
are welcome to adapt as suits you, attached here.
unit triangles;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, types, Graphics, LCLProc;
type
{$M+}
TBaseAlign=(baBottom, baTop, baLeft, baRight);
{$M+}
{ TTriangle }
TTriangle=class(TGraphicControl)
private
FPen: TPen;
FBaseAlign: TBaseAlign;
FBrush: TBrush;
procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen);
procedure SetBaseAlign(aValue: TBaseAlign);
protected
class function GetControlClassDefaultSize: TSize; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure ParamsChanged(Sender: TObject);
published
property Align;
property Anchors;
property BaseAlign: TBaseAlign read FBaseAlign write SetBaseAlign
default baBottom;
property BorderSpacing;
property Brush: TBrush read FBrush write SetBrush;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property Pen: TPen read FPen write SetPen;
property OnChangeBounds;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPaint;
property OnResize;
property OnStartDock;
property OnStartDrag;
property ShowHint;
property Visible;
end;
implementation
{ TTriangle }
procedure TTriangle.SetBrush(Value: TBrush);
begin
if Value <> Brush then
FBrush.Assign(Value);
end;
procedure TTriangle.SetPen(Value: TPen);
begin
if Value <> Pen then
FPen.Assign(Value);
end;
procedure TTriangle.SetBaseAlign(aValue: TBaseAlign);
begin
if aValue<>FBaseAlign then begin
FBaseAlign:=aValue;
ParamsChanged(Self);
end;
end;
class function TTriangle.GetControlClassDefaultSize: TSize;
begin
Result.cx:=65;
Result.cy:=65;
end;
constructor TTriangle.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
ControlStyle := ControlStyle + [csReplicatable];
FPen := TPen.Create;
FPen.OnChange := @ParamsChanged;
FBrush := TBrush.Create;
FBrush.OnChange := @ParamsChanged;
FBaseAlign:=baBottom;
end;
destructor TTriangle.Destroy;
begin
FreeThenNil(FPen);
FreeThenNil(FBrush);
inherited Destroy;
end;
procedure TTriangle.Paint;
var
PaintRect: TRect;
P: array[1..3] of TPoint;
PenInc, PenDec: Integer;
procedure CalcPoints(aBaseAlign: TBaseAlign);
begin
case aBaseAlign of
baBottom: begin P[1].x := (Width - 1) div 2;
P[1].y := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := Height - PenInc - 1;
P[3].x := PenInc;
P[3].y := Height - PenInc - 1; end;
baTop: begin P[3].x := (Width - 1) div 2;
P[1].x := PenInc;
P[2].x := Width - PenInc - 1;
P[3].y := Height - PenInc - 1;
P[1].y := PenInc;
P[2].y := PenInc; end;
baLeft: begin P[1].x := PenInc;
P[1].y := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := (Height - 1) div 2;
P[3].x := PenInc;
P[3].y := Height - PenInc - 1; end;
baRight: begin P[1].y := (Height - 1) div 2;
P[1].x := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := PenInc;
P[3].x := Width - PenInc - 1;
P[3].y := Height - PenInc - 1; end;
end;
end;
begin
Canvas.Pen:=FPen;
Canvas.Brush:=FBrush;
PenInc := Pen.Width div 2;
PenDec := (Pen.Width - 1) div 2;
PaintRect := Rect(PenInc, PenInc, Self.Width - PenDec, Self.Height -
PenDec);
if PaintRect.Left = PaintRect.Right then
PaintRect.Right := PaintRect.Right + 1;
if PaintRect.Top = PaintRect.Bottom then
PaintRect.Bottom := PaintRect.Bottom + 1;
CalcPoints(FBaseAlign);
Canvas.Polygon(P);
inherited Paint;
end;
procedure TTriangle.ParamsChanged(Sender: TObject);
begin
if (Parent <> nil) and (Visible or (csDesigning in ComponentState)) and
Parent.HandleAllocated then
Invalidate;
end;
end.
--
_______________________________________________
Lazarus mailing list
[email protected]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
