Draw title in Stringgrid rotated (top to buttom)

[MoellerCLaus]

I been looking for an example on how to rotate the title text in a columnheader in a stringgridcomponent.
In my application I need a lot of checkboxes in the grid and to minimize the columns width this would come in handy.
I am porting to Lazarus from Delphi. See image.
Thanks for any hint

[winni]

Hi!

In the OI for the StringGrid1 set DefaultDrawing to false.

Create this procedure for the onDrawCell event:

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

1. procedure TForm1.StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
2.   aRect: TRect; aState: TGridDrawState);
3.   var x,y : integer;
4.     s: String;
5. begin
6.   if  aRow = 0 then
7.   begin
8.     x := (aRect.Right-aRect.Left -12) div 2 + aRect.left;
9.     y := aRect.Top+ 3;
10.     StringGrid1.Canvas.Brush.color := StringGrid1.FixedColor;
11.     StringGrid1.canvas.FillRect(aRect);
12.     StringGrid1.Canvas.Font.Orientation := 2700;
13.     StringGrid1.Canvas.Textout(x,y,'Column '+IntToStr(aCol));
14.   end else
15.   begin
16.    x := aRect.Left +2;
17.    y := aRect.Top +2;
18.    if odd (aRow) then StringGrid1.Canvas.Brush.color := StringGrid1.Color else
19.         StringGrid1.Canvas.Brush.color := StringGrid1.AlternateColor;
20.    if gdSelected in aState then StringGrid1.Canvas.Brush.color := clRed;
21.    StringGrid1.canvas.FillRect(aRect);
22.    s := stringGrid1.cells[aCol,aRow];
23.    StringGrid1.Canvas.Font.Orientation := 0;
24.    StringGrid1.Canvas.TextOut(x,y,s);
25.   end;
26. end;
27.  

Winni

[MoellerCLaus]

Thanks Winni
That did it for me.

[wp]

I modified cell painting in the Lazarus grids so that the Font.Orientation is handled correctly. Now you only must set the Orientation of the Column.Title.Font to -900 to get vertical text running downward; use Column.Title.Alignment = taCenter to center the text horizontally within the cell, and Column.Title.Layout = tlTop to move it to the top of the cell. In case of a checkbox column, there is no need any more to paint the checkboxes manually now.

All this is in trunk/main. Since it is a new feature it will not be ported to the fixes branch and thus not be included in Laz v2.2.2.

If you want to have the feature in your current Lazarus version you can do the following changes manually (of course, make a backup of the modified files because I cannot guarantee that the new code is compatible with your Laz version):

* Open unit graphmath.pas (in the components/lazutils folder of the Lazarus installation) and add the following code. Add the declaration of the RotateRect function to the interface part of the unit:

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

1. {-------------------------------------------------------------------------------
2.   Method:  RotatePoint
3.   Params:  APoint, AAngle
4.   Returns: TPoint after rotation
5.  
6.   Rotates a point around the origin (0,0) by the angle AAngle. The angle is
7.   in radians and positive for counter-clockwise rotation.
8.   Note that y points downwards.
9. -------------------------------------------------------------------------------}
10. function RotatePoint(const APoint: TPoint; AAngle: Double): TPoint;
11. var
12.   sa, ca: Double;
13. begin
14.   sa := sin(AAngle);
15.   ca := cos(AAngle);
16.   Result.X := Round( ca * APoint.X + sa * APoint.Y);
17.   Result.Y := Round(-sa * APoint.X + ca * APoint.Y);
18. end;
19.  
20. procedure GetMinMax(x: Integer; var min, max: Integer);
21. begin
22.   if x < min then min := x;
23.   if x > max then max := x;
24. end;
25.  
26. {-------------------------------------------------------------------------------
27.   Method:   RotateRect
28.   Params:   AWidth, AHeight, AAngle
29.   Returns:  smallest TRect containing the rotated rectangle.
30.  
31.   Rotates the rectangle (0, 0, AWidth, AHeight) around its top-left corner (0,0)
32.   by the angle AAngle (in radians).
33.   Note that y points downwards.
34. -------------------------------------------------------------------------------}
35. function RotateRect(AWidth, AHeight: Integer; AAngle: Double): TRect;
36. var
37.   P1, P2, P3: TPoint;
38. begin
39.   if AAngle = 0 then
40.     Result := Rect(0, 0, AWidth, AHeight)
41.   else
42.   begin
43.     P1 := RotatePoint(Point(AWidth, 0), AAngle);
44.     P2 := RotatePoint(Point(0, AHeight), AAngle);
45.     P3 := P1 + P2;
46.  
47.     Result := Rect(0, 0, 0, 0);
48.     GetMinMax(P1.X, Result.Left, Result.Right);
49.     GetMinMax(P2.X, Result.Left, Result.Right);
50.     GetMinMax(P3.X, Result.Left, Result.Right);
51.     GetMinMax(P1.Y, Result.Top, Result.Bottom);
52.     GetMinMax(P2.Y, Result.Top, Result.Bottom);
53.     GetMinMax(P3.Y, Result.Top, Result.Bottom);
54.   end;
55. end;

* Open unit grids.pas (in the lcl folder of the Lazarus installation) and add GraphMath to its implementation "uses" clause.

* In the implementation part of the unit, replace the method TCustomGrid.DrawCellText by the following code:

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

1. procedure TCustomGrid.DrawCellText(aCol, aRow: Integer; aRect: TRect;
2.   aState: TGridDrawState; aText: String);
3. var
4.   Rtxt, Rrot, R: TRect;
5.   angle: Double;
6.   ts: TTextStyle;
7. begin
8.   ts := Canvas.TextStyle;
9.  
10.   if Canvas.Font.Orientation = 0 then
11.   begin
12.     dec(ARect.Right, varCellPadding);
13.     case Canvas.TextStyle.Alignment of
14.       Classes.taLeftJustify: Inc(ARect.Left, varCellPadding);
15.       Classes.taRightJustify: Dec(ARect.Right, 1);
16.     end;
17.     case Canvas.TextStyle.Layout of
18.       tlTop: Inc(ARect.Top, varCellPadding);
19.       tlBottom: Dec(ARect.Bottom, varCellPadding);
20.     end;
21.   end else
22.   begin
23.     angle := Canvas.Font.Orientation * pi / 1800;
24.     Rtxt.TopLeft := Point(0, 0);
25.     Rtxt.BottomRight := TPoint(Canvas.TextExtent(aText));
26.     Rrot := RotateRect(Rtxt.Width, Rtxt.Height, angle);
27.     R := Rrot;
28.     case Canvas.TextStyle.Alignment of
29.       taLeftJustify: OffsetRect(R, -Rrot.Left + varCellPadding, 0);
30.       taCenter: OffsetRect(R, (ARect.Width - Rrot.Width) div 2 - Rrot.Left, 0);
31.       taRightJustify: OffsetRect(R, ARect.Width - Rrot.Right - varCellPadding, 0);
32.     end;
33.     case Canvas.TextStyle.Layout of
34.       tlTop: OffsetRect(R, 0, -Rrot.Top + varCellPadding);
35.       tlCenter: OffsetRect(R, 0, (ARect.Height - Rrot.Height) div 2 - Rrot.Top);
36.       tlBottom: OffsetRect(R, 0, ARect.Height - Rrot.Bottom - varCellPadding);
37.     end;
38.     OffsetRect(R, -Rrot.Left, -Rrot.Top);
39.     OffsetRect(R, ARect.Left, ARect.Top);
40.     ARect := R;
41.     ts.Clipping := false;
42.     ts.Layout := tlTop;
43.     ts.Alignment := taLeftJustify;
44.   end;  
45.  
46.   if ARect.Right<ARect.Left then
47.     ARect.Right:=ARect.Left;
48.   if ARect.Left>ARect.Right then
49.     ARect.Left:=ARect.Right;
50.   if ARect.Bottom<ARect.Top then
51.     ARect.Bottom:=ARect.Top;
52.   if ARect.Top>ARect.Bottom then
53.     ARect.Top:=ARect.Bottom;
54.  
55.   if (ARect.Left<>ARect.Right) and (ARect.Top<>ARect.Bottom) then
56.     Canvas.TextRect(aRect,ARect.Left,ARect.Top, aText, ts);
57. end;

[wp]

Don't ask me... I only wrote the part with Font.Orientation <> 0.

[MoellerCLaus]

Hi Winni and others

As you could see from the above I need to draw checkboxes in some of the cells.

I tried   to use Grid.DefaultDrawing:=True; in procedure TMarkListForm.MarksGridDrawCell(Sender: TObject; aCol, aRow: Integer;
  aRect: TRect; aState: TGridDrawState);

It seems to work for me. An alternative is perhaps to use
   procedure DrawGridCheckboxBitmaps(const aCol,aRow: Integer; const aRect: TRect;
                                        const aState: TCheckboxState); virtual;
 but this as standard protected.

Any hints - thanks

[wp]

I guess you did not read my message about the fix... (Reply #3 on March 13, 2022)

[EDIT]
The attached demo project is created after this modification. All the changes to achieve vertical headers can be made at designtime.

[MoellerCLaus]

Whau WP
Thanks
No I did not try it - I will.
I wote for that your improvement to stringgrid will be part of the next release