Как вывести текст, написанный под углом или вращение текста?

Вариант 1:

Author: Pegas

Source: Vingrad.ru https://forum.vingrad.ru

Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.

procedure TForm1.FormPaint(Sender: TObject);
var
  lf: TLogFont;
begin
  FillChar(lf, SizeOf(lf), 0);
  with lf do begin
    // Высота буквы
    lfHeight := 15;

    // Ширина буквы
    lfWidth := 20;

    // Угол наклона в десятых градуса
    lfEscapement := 100;

     // Жирность 0..1000, 0 - по умолчанию
    lfWeight := 1000;

    // Курсив
    lfItalic := 0;

    // Подчеркнут
    lfUnderline := 1;

    // Зачеркнут
    lfStrikeOut := 1;

    // CharSet
    lfCharSet := RUSSIAN_CharSet;

    // Название шрифта
    StrCopy(lfFaceName, 'Arial');
  end;
  with Form1.Canvas do begin
    FillRect(ClipRect);
    Font.Handle := CreateFontIndirect(lf);
    TextOut(0, 100, 'It is a text string');
  end;
end;

---

Вариант 2:

Author: Зайцев О.В., Владимиров А.М.

Source: https://forum.sources.ru

{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }
{ Шрифт должен быть TrueType ! }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var   LogRec: TLOGFONT;     { Информация о шрифте }
begin
 {Читаем текущюю инф. о шрифте }
 GetObject(c.Font.Handle,SizeOf(LogRec),Addr(LogRec) );
 { Изменяем угол }
 LogRec.lfEscapement := round(d*10);
 { Устанавливаем новые параметры }
 c.Font.Handle := CreateFontIndirect(LogRec);
end;

---

Вариант 3:

Source: https://forum.sources.ru

procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string); 
var hFont, Fontold: integer; 
    DC: hdc; 
    Fontname: string; 
begin 
  if length(txt)= 0 then 
    EXIT; 
  DC:= Screen.ActiveForm.Canvas.handle; 
  SetBkMode(DC, transparent); 
  Fontname:= Screen.ActiveForm.Canvas.Font.Name; 
  hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0, 
                     0,1,4,$10,2,4,PChar(Fontname)); 
  Fontold:= SelectObject(DC, hFont); 
  TextOut(DC,x,y,PChar(txt), length(txt)); 
  SelectObject(DC, Fontold); 
  DeleteObject(hFont); 
end; 

---

Вариант 4:

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

procedure AngleTextOut(CV: TCanvas; const sText:
  string; x, y, angle: integer);
var
  LogFont: TLogFont;
  SaveFont: TFont;
begin
  SaveFont := TFont.Create;
  SaveFont.Assign(CV.Font);
  GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
  with LogFont do
  begin
    lfEscapement := angle * 10;
    lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
  end; {with}
  CV.Font.Handle := CreateFontIndirect(LogFont);
  SetBkMode(CV.Handle, TRANSPARENT);
  CV.TextOut(x, y, sText);
  CV.Font.Assign(SaveFont);
  SaveFont.Free;
end;

---

Вариант 5:

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string);
var
  b1, b2: TBitmap;
  i, j: Integer;
begin
  with bitmap.Canvas do
  begin
    b1 := TBitmap.Create;
    b1.Canvas.Font := lpYhFont;
    b1.Width := TextWidth(s) + 1;
    b1.Height := TextHeight(s) + 1;
    b1.Canvas.TextOut(1, 1, s);

    b2 := TPackedBitmap.Create;
    b2.Width := TextHeight(s);
    b2.Height := TextWidth(s);
    for i := 0 to b1.Width - 1 do
      for j := 0 to b1.Height do
        b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];
    Draw(x, y, b2);
    b1.Free;
    b2.Free;
  end
end;

---

Вариант 6:

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

Некоторое время я делал так: я создавал шрифт, выбирал его в DC ...

function CreateMyFont(degree: Integer): HFONT;
begin
  CreateMyFont := CreateFont(
  -30, 0, degree, 0, 0,
  0, 0, 0, 1, OUT_TT_PRECIS,
  0, 0, 0, szFontName);
end;

.... и затем использовал любую функцию рисования для вывода текста.

---

Вариант 7:

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

Попробуйте это:

procedure TForm1.TextUp(aRect:tRect;aTxt:String);
var 
  LFont: TLogFont; 
  hOldFont, hNewFont: HFont;
begin
  GetObject(Canvas.Font.Handle,SizeOf(LFont),Addr(LFont));
  LFont.lfEscapement := 900;
  hNewFont := CreateFontIndirect(LFont);
  hOldFont := SelectObject(Canvas.Handle,hNewFont);
  Canvas.TextOut(aRect.Left+2,aRect.Top,aTxt);
  hNewFont := SelectObject(Canvas.Handle,hOldFont);
  DeleteObject(hNewFont);
end;

---

Вариант 8:

Выводим цветной текст на форме под любым углом

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 20;
  logfont.lfwidth := 20;
  logfont.lfweight := 750;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;

  font := createfontindirect(logfont);

  SelectObject(Form1.canvas.handle, font);

  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);

  for count := 1 to 10 do
  begin
    Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255)));
  end;

  DeleteObject(font);
end;

---

Вариант 9:

Source: DelphiWorld 6.0 https://delphiworld.narod.ru/

{Create a rotated font based on the font object F}
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
var
  LF: TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do
  begin
    lfHeight := F.Height;
    lfWidth := 0;
    lfEscapement := Angle*10;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in F.Style);
    lfUnderline := Byte(fsUnderline in F.Style);
    lfStrikeOut := Byte(fsStrikeOut in F.Style);
    lfCharSet := DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.name);
    lfQuality := DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else
        lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;

...

{create the rotated font}
if FontAngle <> 0 then
  Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты.