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

Материал из DRKB


Используя TLogFont[править | править код]

Image 2021-02-12 015624.png


Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой 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;  // Угол наклона в десятых градуса
    lfWeight := 1000;  // Жирность 0..1000, 0 - по умолчанию
    lfItalic := 0;     // Курсив
    lfUnderline := 1;  // Подчеркнут
    lfStrikeOut := 1;  // Зачеркнут
    lfCharSet := RUSSIAN_CharSet; // 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;


Author: Pegas
Source: http://forum.vingrad.ru
ID: 03637



{ Эта процедура устанавливает угол вывода текста для указанного 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;


Author: Зайцев О.В.
Author: Владимиров А.М.
Source: http://forum.sources.ru
ID: 03638



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

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;


Source: http://delphiworld.narod.ru/
ID: 03643



Используя CreateFont[править | править код]

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;


Source: http://forum.sources.ru
ID: 03639


Некоторое время я делал так: я создавал шрифт, выбирал его в 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;


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


Source: http://delphiworld.narod.ru/
ID: 03642



С возвратом к прежнему шрифту[править | править код]

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;
  CV.Font.Handle := CreateFontIndirect(LogFont);
  SetBkMode(CV.Handle, TRANSPARENT);
  CV.TextOut(x, y, sText);
  CV.Font.Assign(SaveFont);
  SaveFont.Free;
end;


Source: http://delphiworld.narod.ru/
ID: 03640



Вертикальный текст на TBitmap[править | править код]

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;


Source: http://delphiworld.narod.ru/
ID: 03641



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

Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент 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;


ID: 03644


Создаем наклонный шрифт на базе существующего[править | править код]

{ 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);


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


Source: http://delphiworld.narod.ru/
ID: 03645