2013/12/26 Howard Page-Clark <[email protected]> > 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
-- _______________________________________________ Lazarus mailing list [email protected] http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
