lazarus - 如何更改 Delphi TStringGrid 中固定行单元格中的文本方向

Question

我在表单上有一个标准的 TStringGrid。我在网格中有一个固定行，其中包含许多列，这些列都是 TGridColumns 对象。我已经使用对象检查器设置了列标题，默认方向是水平的。有什么方法可以使方向垂直(就像在 Excel 中的单元格中一样)？

Answer 1

以下是如何在 Lazarus 中垂直渲染第一行的文本:

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Grids,
  StdCtrls;

type
  TStringGrid = class(Grids.TStringGrid)
  protected
    procedure DrawCellText(ACol, ARow: Integer; ARect: TRect;
      AState: TGridDrawState; AText: String); override;
  end;

type
  TForm1 = class(TForm)
    Button1: TButton;
    StringGrid1: TStringGrid;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

procedure TStringGrid.DrawCellText(ACol, ARow: Integer; ARect: TRect;
  AState: TGridDrawState; AText: String);
var
  TextPosition: TPoint;
begin
  if ARow = 0 then
  begin
    Canvas.Font.Orientation := 900;
    TextPosition.X := ARect.Left +
      ((ARect.Right - ARect.Left - Canvas.TextHeight(AText)) div 2);
    TextPosition.Y := ARect.Bottom -
      ((ARect.Bottom - ARect.Top - Canvas.TextWidth(AText)) div 2);
    Canvas.TextOut(TextPosition.X, TextPosition.Y, AText);
  end
  else
    inherited DrawCellText(ACol, ARow, ARect, AState, AText);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
  GridColumn: TGridColumn;
begin
  for I := 0 to 4 do
  begin
    GridColumn := StringGrid1.Columns.Add;
    GridColumn.Width := 24;
    GridColumn.Title.Font.Orientation := 900;
    GridColumn.Title.Layout := tlBottom;
    GridColumn.Title.Caption := 'Column no. ' + IntToStr(I);
  end;
  StringGrid1.RowHeights[0] := 80;
end;

end.

以下是如何渲染TStringGrid的第一行文本Delphi 中的垂直方向:

我更愿意使用覆盖 DrawCell程序，因为在我看来这是最简单的方法，因为如果您想简单地在 OnDrawCell 中渲染文本那么您应该考虑的事件:

• 如果您有 DefaultDrawing设置为True那么当 OnDrawCell 时文本已经被渲染。事件被触发，所以在这里我会推荐例如将单元格标题存储在单独的变量中，而不是存储在 Cells 中属性，这样就不会渲染任何文本，您可以垂直绘制自己存储的标题
• 如果您有 DefaultDrawing设置为False那么你就必须自己绘制整个单元格，包括 3D 边框，恕我直言，这不是那么酷，我个人更喜欢让控件为我们绘制背景
  

这是使用重写 DrawCell 的 Delphi 代码程序。文本在单元格矩形内部居中；请注意，我没有使用 DrawTextEx用于文本大小测量，因为此函数不考虑更改的字体方向。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids;

type
  TStringGrid = class(Grids.TStringGrid)
  protected
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
      AState: TGridDrawState); override;
  end;

type
  TForm1 = class(TForm)
    Button1: TButton;
    StringGrid1: TStringGrid;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
  AState: TGridDrawState);
var
  LogFont: TLogFont;
  TextPosition: TPoint;
  NewFontHandle: HFONT;
  OldFontHandle: HFONT;
begin
  if ARow = 0 then
  begin
    GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont);
    LogFont.lfEscapement := 900;
    LogFont.lfOrientation := LogFont.lfEscapement;
    NewFontHandle := CreateFontIndirect(LogFont);
    OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
    TextPosition.X := ARect.Left +
      ((ARect.Right - ARect.Left - Canvas.TextHeight(Cells[ACol, ARow])) div 2);
    TextPosition.Y := ARect.Bottom -
      ((ARect.Bottom - ARect.Top - Canvas.TextWidth(Cells[ACol, ARow])) div 2);
    Canvas.TextRect(ARect, TextPosition.X, TextPosition.Y, Cells[ACol, ARow]);
    NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
    DeleteObject(NewFontHandle);
  end
  else
    inherited DrawCell(ACol, ARow, ARect, AState);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to StringGrid1.ColCount - 1 do
  begin
    StringGrid1.ColWidths[I] := 24;
    StringGrid1.Cells[I, 0] := 'Column no. ' + IntToStr(I);
  end;
  StringGrid1.RowHeights[0] := 80;
end;

end.

它是这样的: