How to write on a canvas with a rotated font (Views: 54)
Problem/Question/Abstract: I would like to know how to write in any direction on a canvas : to write vertically or with any angle? Answer: Solve 1: { ... } var LogRec: TLogFont; OldFontHandle, NewFontHandle: hFont; begin with Canvas do begin Font := Self.Font; {create a rotated font based on the font object Font} GetObject(Font.Handle, SizeOf(LogRec), Addr(LogRec)); LogRec.lfEscapement := FAngle * 10; LogRec.lfOutPrecision := OUT_DEFAULT_PRECIS; NewFontHandle := CreateFontIndirect(LogRec); {write text on a canvas} TextOut(ARect.Left, ARect.Top, Text) NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle); DeleteObject(NewFontHandle); end; end; Solve 2: Here's a procedure to draw rotated text. To call it, do something like: { ... } Form1.Canvas.Brush.Style := bsClear; TextRotate(Form1.Canvas, 'Rotated Text', W, H, Angle); Where W and H are the x, y position at which to draw the text, and Angle is 0 - 359. procedure TForm1.TextRotate(LocalCanvas: TCanvas; Text: string; X: Integer; Y: Integer; RotateAngle: Integer); var LogFont: TLogFont; begin {Get font information} GetObject(LocalCanvas.Handle, SizeOf(TLogFont), @LogFont); {The angle, in tenths of degrees, between the base line of a character and the x-axis} LogFont.lfEscapement := RotateAngle * 10; LogFont.lfUnderline := 0; LogFont.lfStrikeOut := 0; LogFont.lfWidth := 6; LogFont.lfHeight := 12; LogFont.lfItalic := 0; LogFont.lfQuality := PROOF_QUALITY; LogFont.lfFaceName := 'Times New Roman'; LogFont.lfWeight := 400; {Assign the new rotated font handle} LocalCanvas.Font.Handle := CreateFontIndirect(LogFont); {Print the text} LocalCanvas.TextOut(X, Y, Text); DeleteObject(LocalCanvas.Font.Handle); end; Solve 3: You want to display rotated text? For that you need to use a TrueType font (bitmap fonts cannot be rotated) and a little API to create a rotated font. TFont does not directly support it. The following example shows how to print rotated text. The same principle works on other canvases. procedure TForm1.Button3Click(Sender: TObject); var lf: TLogfont; begin with printer do begin begindoc; canvas.font.Name := 'Arial'; canvas.font.Size := 24; canvas.textout(100, 100, 'This is a normal text'); GetObject(canvas.font.handle, Sizeof(lf), @lf); lf.lfescapement := 450; lf.lforientation := 450; Canvas.Font.handle := CreateFontIndirect(lf); canvas.TextOut(100, 1500, 'This is a rotated text'); EndDoc; end; end; Solve 4: procedure TForm1.Button1Click(Sender: TObject); var LogRec: TLogFont; OldFont, NewFont: HFont; i, X, Y: LongInt; begin if pdPrinter.Execute then begin with Printer do begin GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec); BeginDoc; for i := 0 to 5 do begin LogRec.lfEscapement := (i * 60) * 10; LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS; LogRec.lfFaceName := 'Times New Roman'; NewFont := CreateFontIndirect(LogRec); OldFont := SelectObject(Canvas.Handle, NewFont); Canvas.TextOut(100, 100, 'Hello World!'); NewFont := SelectObject(Canvas.Font.Handle, OldFont); DeleteObject(NewFont); end; EndDoc; end; end; end; end. Solve 5: function GetRotatedFont(Canvas: TCanvas; RotationAngle: integer): HFont; var LogFont: TLogFont; begin GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont); with LogFont do begin if (RotationAngle <> lfEscapement) then begin if RotationAngle = 0 then lfOutPrecision := OUT_DEFAULT_PRECIS else lfOutPrecision := OUT_TT_ONLY_PRECIS; lfEscapement := RotationAngle; lfOrientation := lfEscapement; end; end; Result := CreateFontIndirect(LogFont); end; Solve 6: { ... } var LogFont: TLogFont; fHandle: HFont; begin try Printer.BeginDoc; {Create font} ZeroMemory(@LogFont, SizeOf(LogFont)); LogFont.lfFaceName := 'Times New Roman'; LogFont.lfHeight := 48; LogFont.lfWidth := 0; {Have font mapper choose} LogFont.lfEscapement := 300; {Angle in 1/10ths of a degree} LogFont.lfOrientation := 300; {Angle in 1/10ths of a degree} LogFont.lfQuality := DEFAULT_QUALITY; {Everything else as default} LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS; LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS; fHandle := CreateFontIndirect(LogFont); {Select new font, print the text and delete font} SelectObject(Printer.Canvas.Handle, fHandle); Printer.Canvas.TextOut(100, 300, '30 degree text'); DeleteObject(fHandle); finally Printer.EndDoc; end; end; Solve 7: { ... } var FontName: string; NewFont: Integer; OldFont: Integer; { ... } with Printer.Canvas do begin FontName := Font.Name + #0; NewFont := CreateFont(Font.Height - 1, 0, 900, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, 4, @fontname[1]); OldFont := SelectObject(Handle, NewFont); TextOut(X, Y, Text); SelectObject(Handle, OldFont); DeleteObject(NewFont); end; { ... } The value '900' is tenths of degrees. |