Text Gedreht auf ein Canvas Schreiben [gelöst]

[corpsman]

Guten Morgen allerseits,

Ich will auf ein TCanvas ( Eigentlich immer TBitmap.canvas, oder TPrinter.Canvas ) einen Rotierten Text schreiben.

Dies mache ich mittels :

Code: Alles auswählen

Procedure gedrehterText(Const Canvas: TCanvas; x, y, Angle: Integer; Text: String);
Var
  lf: TLogFont;
  tf: TFont;
  name: String;
Begin
  name := canvas.Font.name;
  canvas.Font.Name := 'Arial';
  canvas.brush.color := Clwhite;
  tf := TFont.Create;
  Try
    tf.Assign(canvas.Font);
    GetObject(tf.Handle, sizeof(lf), @lf);
    lf.lfEscapement := angle * 10;
    lf.lfOrientation := angle * 10;
    tf.Handle := CreateFontIndirect(lf);
    canvas.Font.Assign(tf);
    canvas.TextOut(x, y, Text);
    lf.lfEscapement := 0;
    lf.lfOrientation := 0;
    tf.Handle := CreateFontIndirect(lf);
    canvas.Font.Assign(tf);
  Finally
    tf.free;
  End;
  canvas.brush.Style := bsClear;
  canvas.Font.name := name;
End;

Momentan funktioniert das auch noch, doch der Compiler bewirft mich mit :

uSimpleCAD.pas(148,18) Warning: Symbol "Handle" is deprecated
uSimpleCAD.pas(151,8) Warning: Symbol "Handle" is deprecated
uSimpleCAD.pas(156,8) Warning: Symbol "Handle" is deprecated
uSimpleCAD.pas(106,69) Hint: Parameter "Farbig" not used
Project "SimpleCAD" successfully built

Daher die Frage, wie macht ihr das denn ?

[Teekeks]

Code: Alles auswählen

Procedure gedrehterText(Const Canvas: TCanvas; x, y, Angle: Integer; Text: String);
{$HINTS OFF}
{$WARNINGS OFF}
    Var
      lf: TLogFont;
      tf: TFont;
      name: String;
    Begin
      name := canvas.Font.name;
      canvas.Font.Name := 'Arial';
      canvas.brush.color := Clwhite;
      tf := TFont.Create;
      Try
        tf.Assign(canvas.Font);
        GetObject(tf.Handle, sizeof(lf), @lf);
        lf.lfEscapement := angle * 10;
        lf.lfOrientation := angle * 10;
        tf.Handle := CreateFontIndirect(lf);
        canvas.Font.Assign(tf);
        canvas.TextOut(x, y, Text);
        lf.lfEscapement := 0;
        lf.lfOrientation := 0;
        tf.Handle := CreateFontIndirect(lf);
        canvas.Font.Assign(tf);
      Finally
        tf.free;
      End;
      canvas.brush.Style := bsClear;
      canvas.Font.name := name;
{$HINTS ON}
{$WARNINGS ON}
    End;

[corpsman]

Diese hoffentlich eher als Scherz als ernst gemeinte Antwort, bedeutet dann das man den Text tatsächlich nur so gedreht aufs Canvas bringt ?

[Teekeks]

Sagen wir es so:
So wie ich dich verstanden habe funktioniert deines und es stören dich nur die Fehlermeldungen?

Wenn ja: dann kannst du das wirklich so machen.

Und es kommt noch hinzu das ich keine andere Methode weiß im Moment.

[carli]

Also bei Delphi hab ich dann aufgegeben, als es ums Drehen ging.
Ich hab mir dann selber ne Rotationsfunktion geschrieben, die aber Löcher hatte und dank des Zugriffs auf Pixels[] sau langsam war.

Meine Lösung hieß damals und heißt immer noch OpenGL.

[Teekeks]

@Corpsman: Ich nehme an du hast deinen Code von dem hier: http://www.delphipraxis.net/396730-post.html?

[theo]

Wegen der paar Warnungen würde ich jetzt auch keinen Aufstand machen.
Aber es geht auch einfacher:

Canvas.Font.Orientation:=450;
Canvas.TextOut(10,10,'hugo');

[corpsman]

*g*

Mich hat

Englisch ---> Deutsch:
deprecated --> abgelehnt
deprecated --> missbilligte
deprecated --> veraltet

Einfach "nervös" gemacht.

Theos Lösung ist mir da einfach "Sympatischer".

Für Alle Mitleser : Angle wird im Gradmas * 10 übergeben.

[Edit]

sagt mal ist das ein Bug dass wenn ich als String 'Hallo'#13#10'Welt' übergebe. Dass ich dann Welt 2 mal lesen kann ?

[Edit2]

Hier ein kleiner workaround

Code: Alles auswählen

Procedure gedrehterText(Const Canvas: TCanvas; x, y, Angle: Integer; Text: String);
Var
  drx, dry: Double;
  l, dy: Integer;
  s, c: extended;
  tmptext: String;
Begin
  While Angle < 0 Do
    inc(angle, 360);
  Angle := Angle Mod 360;
  While pos(#13#10, text) <> 0 Do
    delete(text, pos(#13#10, text), 1);
  While pos(#13, text) <> 0 Do
    text[pos(#13, text)] := #10;
  dy := canvas.TextHeight('8');
  sincos(degtorad(angle), s, c);
  drx := -s * dy;
  dry := c * dy;
  l := 0;
  canvas.Font.Orientation := angle * 10;
  While pos(#10, text) <> 0 Do Begin
    tmptext := copy(text, 1, pos(#10, text) - 1);
    delete(text, 1, pos(#10, text));
    canvas.TextOut(x - round(l * drx), y + round(l * dry), tmpText);
    inc(l);
  End;
  If Length(text) <> 0 Then Begin
    canvas.TextOut(x - round(l * drx), y + round(l * dry), Text);
  End;
  canvas.Font.Orientation := 0;
End;

[theo]

So müsste es gehen:

Code: Alles auswählen

procedure TForm1.FormPaint(Sender: TObject);
var Style:TTextStyle;
begin
  with Style do
  begin
    Alignment := taLeftJustify;
    Layout := tlTop;
    WordBreak := True;
    SingleLine := False;
    Clipping := True;
    ShowPrefix := False;
    Opaque := False;
    SystemFont:=false;
  end;
  Canvas.Font.Orientation:=450;
  Canvas.TextRect(BoundsRect,100,100,'Hallo'#13#10'Welt',Style);
end;

P.S. für deinen Ansatz gibt's auch noch eine Fkt (Zeilenumbruch normalisieren):

Code: Alles auswählen

aString:=AdjustLineBreaks(aString,tlbsLF);

[corpsman]

Wow,

sag mal gibts eigentlich irgendwo ein Buch oder ein Tutorial, wo man das alles nachlesen kann was du hier aus dem Hut zauberst ?

Normalerweise mache ich es ja wie Carli, mit OpenGL, muss aber zugeben ich bin echt überrascht, wie viel die LCL kann, und in manchen fällen, eben genau dem für welchen ich es gerade Progge, ist es schon cool.

[theo]

sag mal gibts eigentlich irgendwo ein Buch oder ein Tutorial, wo man das alles nachlesen kann was du hier aus dem Hut zauberst ?

Naja, dokumentiert ist es schon:
http://lazarus-ccr.sourceforge.net/docs ... trect.html
http://lazarus-ccr.sourceforge.net/docs ... style.html
http://lazarus-ccr.sourceforge.net/docs ... reaks.html

Aber meistens weiss man ja nicht, wonach man suchen soll.
Da können (auch alte) Delphi Bücher u.U. helfen oder das Lazarusbuch (das ich nicht besitze).
Immer gut ist auch, Code-Insight oder den Quelltext anzuschauen.
Da stösst du auf Canvas.TextRect und kannst ja mal untersuchen was das tut (F1 hilft auch).

[corpsman]

*g*

thx.

Hier noch die Ermittlung der überdeckten Fläche des Textes, allerdings nach meiner Variante.

Code: Alles auswählen

Type
 
  TOOBB = Array[0..3] Of TPoint;
 
Function GetTextOOBB(Const Canvas: TCanvas; x, y, Angle, Size: Integer; Text: String): TOOBB;
Var
  drox, droy, drx, dry: Double;
  w, l, dy: Integer;
  s, c: extended;
  tmptext: String;
  os: integer;
Begin
  os := canvas.Font.Size;
  canvas.Font.Size := Size;
  While Angle < 0 Do
    inc(angle, 360);
  Angle := Angle Mod 360;
  Text := AdjustLineBreaks(Text, tlbsLF);
  dy := canvas.TextHeight('8');
  sincos(degtorad(angle), s, c);
  drx := -s * dy;
  dry := c * dy;
  drox := -c;
  droy := -s;
  l := 0;
  w := 0;
  While pos(#10, text) <> 0 Do Begin
    tmptext := copy(text, 1, pos(#10, text) - 1);
    delete(text, 1, pos(#10, text));
    w := max(w, canvas.TextWidth(tmpText));
    inc(l);
  End;
  If Length(text) <> 0 Then Begin
    inc(l);
  End;
  result[0].x := x;
  result[0].y := y;
  result[1].x := round(x - drox * w);
  result[1].y := round(y + droy * w);
  result[2].x := round(x - (l * drx) - drox * w);
  result[2].y := round(y + (l * dry) + droy * w);
  result[3].x := round(x - l * drx);
  result[3].y := round(y + l * dry);
  canvas.Font.Size := os;
End;