Listing 16

//Routine zur Ausgabe von gedrehtem Text (True Type Fonts)

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;