interface
uses Windows, Messages, SysUtils, Classes, Graphics;
procedure TextOutEx(drwCanvas: TCanvas; drwX, drwY, drwAngle: Integer; drwText: string);
implementation
procedure TextOutEx(drwCanvas: TCanvas; drwX, drwY, drwAngle:
Integer; drwText: string);
var newfont, oldfont,
fontheight, fontstyle, fontitatic, fontunderline,
fontstrikeout: Integer;
fontname: string;
begin
if drwText='' then Exit;
fontheight:=drwCanvas.TextHeight('Wg');
if (fsBold in drwCanvas.Font.Style)
then fontstyle:=FW_BOLD else fontstyle:=FW_NORMAL;
if (fsItalic in drwCanvas.Font.Style)
then fontitatic:=1 else fontitatic:=0;
if (fsUnderline in drwCanvas.Font.Style)
then fontunderline:=1 else fontunderline:=0;
if (fsStrikeOut in drwCanvas.Font.Style)
then fontstrikeout:=1 else fontstrikeout:=0;
fontname:=drwCanvas.Font.Name;
newfont := CreateFont(fontheight, 0, drwAngle*10,
0, fontstyle, fontitatic, fontunderline, fontstrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH,
PChar(fontname));
oldfont := SelectObject(drwCanvas.Handle,
newfont);
TextOut(drwCanvas.Handle, drwX, drwY, PChar(drwText),
Length(drwText));
SelectObject(drwCanvas.Handle, oldfont);
DeleteObject(newfont);
end;