[Lazarus] Adding shapes to TShape

[Howard Page-Clark]

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.