Как вывести текст, написанный под углом или вращение текста |
Previous Top Next |
Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.
Code: |
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;
|
©Drkb::03637
Автор: Pegas
Взято с Vingrad.ru http://forum.vingrad.ru
Code: |
{ Эта процедура устанавливает угол вывода текста для указанного 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; |
©Drkb::03638
Зайцев О.В.
Владимиров А.М.
Взято из http://forum.sources.ru
Code: |
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; |
©Drkb::03639
Взято из http://forum.sources.ru
Code: |
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; |
©Drkb::03640
DelphiWorld 6.0
Code: |
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; |
©Drkb::03641
DelphiWorld 6.0
Некоторое время я делал так: я создавал шрифт, выбирал его в DC ...
Code: |
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; |
.... и затем использовал любую функцию рисования для вывода текста.
©Drkb::03642
DelphiWorld 6.0
Попробуйте это:
Code: |
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; |
©Drkb::03643
DelphiWorld 6.0
Выводим цветной текст на форме под любым углом
Пример демонстрирует вывод теста случайным образом на форме под определённым углом. Добавляем в форму компонент TButton и в событие OnClick следующий код:
Code: |
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; |
©Drkb::03644
Code: |
{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); ...
|
Вращаются только векторные шрифты.
©Drkb::03645
DelphiWorld 6.0