Angled text

Copyright © 2000 Ernesto De Spirito

You surely have seen some labels and other components allow you to rotate the text. For example with the JfControls Library you can rotate the captions of labels, buttons, checkboxes, radiobuttons, list items, menu items, etc. You can achieve the same effect using the lfEscapement and lfOrientation fields of the font object structure, that store the angle of the text measured in tenths of degrees (for example a value of 150 means 15 degrees).

The following function returns the handle of a font with the same characteristics of the font whose handle is passed as parameter, but it allows setting its angle and quality.

interface

uses Windows;

function CreateAngledFont(Font: HFont; Angle: Longint;
  Quality: byte = PROOF_QUALITY): HFont;

implementation

function CreateAngledFont(Font: HFont; Angle: Longint;
  Quality: byte): HFont;
var
  FontInfo: TLogFontA;    // Font information structure
begin
  // Get the information of the font passed as parameter
  if GetObject(Font, SizeOf(FontInfo), @FontInfo) = 0 then begin
    Result := 0;
    exit;
  end;
  // Set the angle
  FontInfo.lfEscapement := Angle;
  FontInfo.lfOrientation := Angle;
  // Set the quality
  FontInfo.lfQuality := Quality;
  // Create a new font with the modified information
  // The new font must be released calling DeleteObject
  Result := CreateFontIndirect(FontInfo);
end;

We can use this function in a procedure that displays rotated text on any canvas, including for example the canvas of a printer:

uses Graphics, Windows;

procedure TextOutA(Canvas: TCanvas; X, Y, Angle: Integer;
  Text: string);
var
  OriginalFont, AngledFont: HFont;
begin
  // Create an angled font from the current font
  AngledFont := CreateAngledFont(Canvas.Font.Handle, Angle);
  if AngledFont <> 0 then begin
    // Set it temporarily as the current font
    OriginalFont := SelectObject(Canvas.Handle, AngledFont);
    if OriginalFont <> 0 then begin
      // Write the text
      Canvas.TextOut(X, Y, Text);
      // Restore the original font
      if SelectObject(Canvas.Handle, OriginalFont) = 0 then begin
        Canvas.Font.Handle := AngledFont;
        // raise Exception.Create('Couldn''t restore font');
        exit;
      end;
    end;
    // Release the angled font
    DeleteObject(AngledFont)
  end;
end;

Here's an example of use:

procedure TForm1.FormPaint(Sender: TObject);
begin
  Font.Name := 'Arial';  // IMPORTANT: True Type Font
  Font.Size := 14;
  Canvas.Brush.Color := Color;
  TextOutA(Canvas, 10, 40, 150, 'Hello world!');
end;

If we want we can assign the handle of an angled font to the Handle property of a TFont object. The handle will be deleted automatically when this object is destroyed.

The following example uses this technique to draw the items of a listbox:

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Set the font of the listbox to have a 10-degree inclination
  with ListBox1.Font do Handle := CreateAngledFont(Handle, 100);
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
const
  TopOffset = 16;
begin
  with (Control as TListBox).Canvas do begin
    FillRect(Rect);
    TextOut(Rect.Left + 2, Rect.Top + TopOffset,
      TListBox(Control).Items[Index]);
  end;
end;