How to write on a canvas with a rotated font

Problem/Question/Abstract:

I would like to know how to write in any direction on a canvas : to write vertically or with any angle?

Answer:

Solve 1:

{ ... }
var
  LogRec: TLogFont;
  OldFontHandle, NewFontHandle: hFont;
begin
  with Canvas do
  begin
    Font := Self.Font;
    {create a rotated font based on the font object Font}
    GetObject(Font.Handle, SizeOf(LogRec), Addr(LogRec));
    LogRec.lfEscapement := FAngle * 10;
    LogRec.lfOutPrecision := OUT_DEFAULT_PRECIS;
    NewFontHandle := CreateFontIndirect(LogRec);
    {write text on a canvas}
    TextOut(ARect.Left, ARect.Top, Text)
      NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
    DeleteObject(NewFontHandle);
  end;
end;


Solve 2:

Here's a procedure to draw rotated text. To call it, do something like:

{ ... }
Form1.Canvas.Brush.Style := bsClear;
TextRotate(Form1.Canvas, 'Rotated Text', W, H, Angle);

Where W and H are the x, y position at which to draw the text, and Angle is 0 - 359.

procedure TForm1.TextRotate(LocalCanvas: TCanvas; Text: string; X: Integer;
  Y: Integer; RotateAngle: Integer);
var
  LogFont: TLogFont;
begin
  {Get font information}
  GetObject(LocalCanvas.Handle, SizeOf(TLogFont), @LogFont);
  {The angle, in tenths of degrees, between the base line of a character and the x-axis}
  LogFont.lfEscapement := RotateAngle * 10;
  LogFont.lfUnderline := 0;
  LogFont.lfStrikeOut := 0;
  LogFont.lfWidth := 6;
  LogFont.lfHeight := 12;
  LogFont.lfItalic := 0;
  LogFont.lfQuality := PROOF_QUALITY;
  LogFont.lfFaceName := 'Times New Roman';
  LogFont.lfWeight := 400;
  {Assign the new rotated font handle}
  LocalCanvas.Font.Handle := CreateFontIndirect(LogFont);
  {Print the text}
  LocalCanvas.TextOut(X, Y, Text);
  DeleteObject(LocalCanvas.Font.Handle);
end;


Solve 3:

You want to display rotated text? For that you need to use a TrueType font (bitmap fonts cannot be rotated) and a little API to create a rotated font. TFont does not directly support it.

The following example shows how to print rotated text. The same principle works on other canvases.

procedure TForm1.Button3Click(Sender: TObject);
var
  lf: TLogfont;
begin
  with printer do
  begin
    begindoc;
    canvas.font.Name := 'Arial';
    canvas.font.Size := 24;
    canvas.textout(100, 100, 'This is a normal text');
    GetObject(canvas.font.handle, Sizeof(lf), @lf);
    lf.lfescapement := 450;
    lf.lforientation := 450;
    Canvas.Font.handle := CreateFontIndirect(lf);
    canvas.TextOut(100, 1500, 'This is a rotated text');
    EndDoc;
  end;
end;


Solve 4:

procedure TForm1.Button1Click(Sender: TObject);
var
  LogRec: TLogFont;
  OldFont, NewFont: HFont;
  i, X, Y: LongInt;
begin
  if pdPrinter.Execute then
  begin
    with Printer do
    begin
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      BeginDoc;
      for i := 0 to 5 do
      begin
        LogRec.lfEscapement := (i * 60) * 10;
        LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
        LogRec.lfFaceName := 'Times New Roman';
        NewFont := CreateFontIndirect(LogRec);
        OldFont := SelectObject(Canvas.Handle, NewFont);
        Canvas.TextOut(100, 100, 'Hello World!');
        NewFont := SelectObject(Canvas.Font.Handle, OldFont);
        DeleteObject(NewFont);
      end;
      EndDoc;
    end;
  end;
end;

end.


Solve 5:

function GetRotatedFont(Canvas: TCanvas; RotationAngle: integer): HFont;
var
  LogFont: TLogFont;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont);
  with LogFont do
  begin
    if (RotationAngle <> lfEscapement) then
    begin
      if RotationAngle = 0 then
        lfOutPrecision := OUT_DEFAULT_PRECIS
      else
        lfOutPrecision := OUT_TT_ONLY_PRECIS;
      lfEscapement := RotationAngle;
      lfOrientation := lfEscapement;
    end;
  end;
  Result := CreateFontIndirect(LogFont);
end;


Solve 6:

{ ... }
var
  LogFont: TLogFont;
  fHandle: HFont;
begin
  try
    Printer.BeginDoc;
    {Create font}
    ZeroMemory(@LogFont, SizeOf(LogFont));
    LogFont.lfFaceName := 'Times New Roman';
    LogFont.lfHeight := 48;
    LogFont.lfWidth := 0; {Have font mapper choose}
    LogFont.lfEscapement := 300; {Angle in 1/10ths of a degree}
    LogFont.lfOrientation := 300; {Angle in 1/10ths of a degree}
    LogFont.lfQuality := DEFAULT_QUALITY;
    {Everything else as default}
    LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
    LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
    fHandle := CreateFontIndirect(LogFont);
    {Select new font, print the text and delete font}
    SelectObject(Printer.Canvas.Handle, fHandle);
    Printer.Canvas.TextOut(100, 300, '30 degree text');
    DeleteObject(fHandle);
  finally
    Printer.EndDoc;
  end;
end;


Solve 7:

{ ... }
var
  FontName: string;
  NewFont: Integer;
  OldFont: Integer;
  { ... }
  with Printer.Canvas do
  begin
    FontName := Font.Name + #0;
    NewFont := CreateFont(Font.Height - 1, 0, 900, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, 4, @fontname[1]);
    OldFont := SelectObject(Handle, NewFont);
    TextOut(X, Y, Text);
    SelectObject(Handle, OldFont);
    DeleteObject(NewFont);
  end;
  { ... }

The value '900' is tenths of degrees.