Решение 1 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; Решение 2 Вот как я решил эту проблему: 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; Решение 3 Некоторое время я делал так: я создавал шрифт, выбирал его в 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; .... и затем использовал любую функцию рисования для вывода текста. Решение 4 Приведенное выше решение (1) очень медленно, так как требует рисования текста и содержит, на мой взгляд, неэффективный метод вращения. Попробуйте взамен это: 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; |