[Lazarus] Adding shapes to TShape

[Frederic Da Vitoria]

2013/12/26 Howard Page-Clark <hdpc at talktalk.net>

> 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.
>

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)

Thank you, Howard

-- 
Frederic Da Vitoria
(davitof)

Membre de l'April - « promouvoir et défendre le logiciel libre » -
http://www.april.org
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.lazarus-ide.org/pipermail/lazarus/attachments/20131226/fa1ca904/attachment-0003.html>