Jon G

procedure DrawVerticalText(Canvas: TCanvas; Rect: TRect; Text: string);
var
  LogRec: TLOGFONT;
  OldFont, NewFont: HFONT;
  Flags: Integer;
  i : Integer;
  SL : TStringlist;
  S : String;
  TH : Integer;
begin
  Flags := DT_NOPREFIX or DT_BOTTOM or DT_EXTERNALLEADING or DT_SINGLELINE;
  with Canvas do
  begin
    Brush.Style := bsClear;
    GetObject(Font.Handle, SizeOf(LogRec), @LogRec);
    LogRec.lfEscapement := 900;
    LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
    NewFont := CreateFontIndirect(LogRec);
    OldFont := SelectObject(Canvas.Handle, NewFont);
    if Pos(#13,Text) = 0 then
      DrawText(Canvas.Handle, PAnsiChar(Text), Length(Text), Rect, Flags)
    else
    begin
      // Windows.DrawText has a bug that can't handle multiple lines in non-horizontal orientation.
      // See http://msdn.microsoft.com/en-us/library/dd162498(VS.85).aspx
      SL := TStringlist.Create;
      SL.Text := Text;
      TH := TextHeight(Text);
      For i := 0 to SL.Count - 1 do
      begin
        S := SL.Strings[i];
        DrawText(Canvas.Handle, PAnsiChar(S), Length(S), Rect, Flags);
        Inc(Rect.Left,TH);
      end;
      SL.Free;
    end;
    NewFont := SelectObject(Canvas.Handle,OldFont);
    DeleteObject(NewFont);
  end;
end;