Extending TShape control

[simsee]

I premise that my knowledge of LCL is not deep. For this I ask for help from those of you more experienced. I want to extend TShape so that it can draw other shapes currently supported. For example a simple line.

My code is as follows:

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls;
9.  
10. type
11.  
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     procedure FormShow(Sender: TObject);
16.   private
17.  
18.   public
19.  
20.   end;
21.  
22.   TShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
23.     stEllipse, stCircle, stSquaredDiamond, stDiamond,
24.     stTriangle, stTriangleLeft, stTriangleRight, stTriangleDown,
25.     stStar, stStarDown, stLine); //stLine new shape type
26.  
27.   { TMyShape }
28.  
29.   TExtShape=class(TShape)
30.     private
31.       fShapeType : TShapeType;
32.     public
33.       property ShapeType : TShapeType read fShapeType write fShapeType;
34.       procedure Paint; override;
35.   end;
36.  
37. var
38.   Form1: TForm1;
39.  
40. implementation
41.  
42. {$R *.lfm}
43.  
44. { TMyShape }
45.  
46. procedure TExtShape.Paint;
47. begin
48.   if fShapeType=stLine then
49.     Canvas.Line(Left,Top,Left+Width,Top+Height)
50.   else
51.     inherited Paint;
52. end;
53.  
54. { TForm1 }
55.  
56. procedure TForm1.FormShow(Sender: TObject);
57. begin
58.   with TExtShape.Create(Self) do
59.     begin
60.       Parent:=Self;
61.       ShapeType:=stLine;
62.       Pen.Color:=clRed; //It does not work
63.       SetBounds(10,10,500,500);
64.     end;
65. end;
66.  
67. end.

While it appears to work, it is actually incorrect. For example, I can't set the color of the new shape of type stLine, because in the overridden method Paint I don't call inherithed in this case. If I did, the default shape would in fact be drawn. How can I overcome the problem? Thank you.

[wp]

In the new shape's Paint procedure you do not apply the Pen to the Canvas:

Code: Pascal  [Select][+][-]

1. procedure TExtShape.Paint;
2. begin
3.   if fShapeType=stLine then
4.   begin
5.     Canvas.Pen.Assign(Pen);
6.     Canvas.Line(Left,Top,Left+Width,Top+Height);
7.   end
8.   else
9.     inherited Paint;
10. end;
11.  
12.  
13. { TForm1 }
14.  
15. procedure TForm1.FormShow(Sender: TObject);
16. begin
17.   with TExtShape.Create(Self) do
18.   begin
19.     Parent:=Self;
20.     ShapeType:=stLine;
21.     Pen.Color:=clRed;
22.     Pen.Width := 3;
23.     Pen.Style := psDash;
24.     SetBounds(10,10,500,500);
25.   end;
26. end;

[simsee]

Thanks Wp (I was hoping it was you to answer, thanks!).

I thought about this solution too. But examining TShape.Paint procedure I see that there are a series of preliminary operations and checks, before starting the drawing of the figures. I guess I have to repeat them all in the overridden Paint method. Right?

[wp]

I looked at the TShape.Paint method, it is not very friendly for overwriting. You certainly must repeat copying the Pen and Brush to the Canvas; you may also want the half-pen widths PenInc and PenDec to avoid clipping of the half line width when the lines reach the control bounds. And, depending on how flexible you want your component to be, you should also fire the OnPaint event at the end.

Be careful with the TShapeType. It already exists in the inherited component as published property Shape. So, when you add a new ShapeType property you still have the inherited Shape - which one will win when the user sets Shape to stRectangle and ShapeType to stCircle? Basically you should remove the property Shape, so that there is only your ShapeType. But Shape is published, and it is not possible to reduce its visiblity. It is possible to hide it in the object inspector, but you still can access it at runtime...

One solution could be to keep both properties: the original Shape: TShapeType = (stRectangle..stStar) and your OverrideShape: TShapeTypeExt = (stNormal, stLine, etc). The option stNormal would mean that one of the original Shape types should be used for drawing. Not very nice...

The other solution is not very satisfying either: Since TShape is rather simple you could rewrite it from scratch, copying everything that you need and replace the TShape by your extended shape types. But doing this you will have the same mess.

Writing a component descending from TShape is not a very instructive exercise...

[simsee]

Thanks wp. I don't have much experience writing custom components. I have studied your excellent chapter on this topic in the Lazaurs Handbook, so I'm happy to receive your response.

In fact I'm realizing that writing a component that has TShape as an ancestor is not simple. However, this is a need I have in my application. Your suggestions are helpful for this purpose.

[wp]

How often do you need this component? Only in this project? In such a case I do not see a justification to take the effort of creating a dedicated component if there are other ways to achieve what you need. For example, you could use the OnPaint event of the TShape to override painting with "your" shapes. Or you don't need any component at all, you could paint directly on the canvas of the form, panel, or whatever, in their OnPaint event.

Here is an example how to draw your "stLine" in a standard TShape by means of its OnPaint event:

Code: Pascal  [Select][+][-]

1. procedure TForm1.Shape1Paint(Sender: TObject);
2. begin
3.   Shape1.Canvas.Pen.Color := clRed;
4.   Shape1.Canvas.Pen.Style := psSolid;
5.   Shape1.Canvas.Line(10, 10, Shape1.Width-10, Shape1.Height-10);
6. end;
7.  
8. procedure TForm1.FormCreate(Sender: TObject);
9. begin
10.   // We do not want to see the inherited shape types.
11.   Shape1.Pen.Style := psClear;
12.   Shape1.Brush.Style := bsClear;
13. end;

And here is an example how to draw on the form directly:

Code: Pascal  [Select][+][-]

1. procedure TForm1.FormPaint(Sender: TObject);
2. begin
3.   Canvas.Pen.Color := clRed;
4.   Canvas.Line(10, 10, 200, 200);
5. end;

[simsee]

Thanks for the interesting ideas. In the meantime I did the following:

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls;
9.  
10. type
11.  
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     procedure FormShow(Sender: TObject);
16.   private
17.  
18.   public
19.  
20.   end;
21.  
22.   TExtShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
23.     stEllipse, stCircle, stSquaredDiamond, stDiamond,
24.     stTriangle, stTriangleLeft, stTriangleRight, stTriangleDown,
25.     stStar, stStarDown, stLine);
26.  
27.   { TMyShape }
28.  
29.   TExtShape=class(TShape)
30.     private
31.       fExtShape : TExtShapeType;
32.     public
33.       property ExtShape : TExtShapeType read fExtShape write fExtShape;
34.       procedure Paint; override;
35.   end;
36.  
37. var
38.   Form1: TForm1;
39.  
40. implementation
41.  
42. {$R *.lfm}
43.  
44. { TMyShape }
45.  
46. procedure TExtShape.Paint;
47. begin
48.   if fExtShape=stLine then
49.     begin
50.       Canvas.Pen.Assign(Pen);
51.       Canvas.Brush.Assign(Brush);
52.       Canvas.Line(Left,Top,Left+Width,Top+Height);
53.     end
54.   else
55.     begin
56.       Shape:=TShapeType(fExtShape);
57.       inherited Paint;
58.     end;
59. end;
60.  
61. { TForm1 }
62.  
63. procedure TForm1.FormShow(Sender: TObject);
64. begin
65.   with TExtShape.Create(Self) do
66.     begin
67.       Parent:=Self;
68.       ExtShape:=stLine;
69.       Pen.Color:=clRed;
70.       SetBounds(10,10,500,500);
71.     end;
72.  
73.   with TExtShape.Create(Self) do
74.     begin
75.       Parent:=Self;
76.       ExtShape:=stCircle;
77.       Pen.Color:=clRed;
78.       SetBounds(10,10,500,500);
79.     end;
80. end;
81.  
82. end.

It's not elegant, I admit it...