Rotation de caractères

Version imprimable

24/03/2007, 13h32
Archimède

Rotation de caractères

voilà, comment faire une rotation de caractères dans un canvas alors que le textout ne permet que des translations circulaires.
j'avais la solution dans mes archives à partir de l'apis windows mais je ne la retrouve pas...
merci

Salut !

J'avais ça dans un coin :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
function IsTrueType(Font: TFont): Boolean;
var DC: HDC;
    C : TBitmap;
    Metrics: TTextMetric;
begin
  C := TBitmap.create;
  try
    C.canvas.Font := Font;
    DC := GetDC(0);
    try
    C.Canvas.Handle := DC;
    C.Canvas.Font := Font;
    GetTextMetrics(C.Canvas.Handle, Metrics );
    Result := ( Metrics.tmPitchAndFamily and tmpf_TrueType ) = tmpf_TrueType;
    C.Canvas.Handle := 0;
    finally
      ReleaseDC(0, DC);
    end;
  finally
    C.Free;
  end;
end;
 
function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
var
  LogFont: TLogFont;
begin
  If not IsTrueType(Font) then Font.Name:='Arial';
  FillChar(LogFont, SizeOf(LogFont), 0);
  with LogFont do begin
    lfHeight := Font.Height;
    lfWidth := 0;
    lfEscapement := Angle * 10;
    lfOrientation := 0;
    if fsBold in Font.Style then lfWeight := FW_BOLD
    else lfWeight := FW_NORMAL;
    lfItalic := Ord(fsItalic in Font.Style);
    lfUnderline := Ord(fsUnderline in Font.Style);
    lfStrikeOut := Byte(fsStrikeOut in Font.Style);
    lfCharSet := Byte(Font.Charset);
    StrPCopy(lfFaceName, Font.Name);
    lfQuality := DEFAULT_QUALITY;
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case Font.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LogFont);
end;
 
procedure TexteAngle(AString: string;ACanvas:TCanvas;Font:TFont;x,y:integer;d:integer); //angle en degres
begin
  ACanvas.Font := Font;
  with ACanvas do
  begin
   Brush.Color := clYellow;
   Font.Handle := CreateRotatedFont(Font, d);
   TextOut(X, Y, AString);
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  TexteAngle('Bonjour', Form1.Canvas, Form1.Font, 50, 70, 45);
  TexteAngle('Bonjour', Form1.Canvas, Form1.Font, 50, 70, 180);
  TexteAngle('Bonjour', Form1.Canvas, Form1.Font, 50, 70, -90);
end;

Me rappelle pas où je l'ai trouvé, mais ça fonctionne.

HTH,
--
jp

24/03/2007, 19h01
Archimède

pas mal du tout ton coin ;)
merci à toi.
je teste tout ça et j'adapte à mon code..
24/03/2007, 23h25
LadyWasky

Citation:

Envoyé par Jipété

Me rappelle pas où je l'ai trouvé, mais ça fonctionne.

Moi je m'en souvien (c'est un copyleft "Ma pomme à moi" :aie: :king: )
http://www.developpez.net/forums/sho...70&postcount=3

Sinon, j'ai une remarque à formuler, sous cette forme, il ne te sera peut-être pas très facile de placer ton texte exactement là où tu veux (Par défaut, c'est le coin supérieur gauche qui sert de point d'ancrage x/y au texte dessiné).

Mais j'avais déjà proposé une solution ici :
http://www.developpez.net/forums/sho...11&postcount=4

bon dev ;)

merci, je viens de découvrir ton post, je n'ai pas regardé ton source...
je vais le faire ...
sinon j'ai bidouillé ça hier soir à partir du code fourni, exemple:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 
unit Unit1;
 
interface
{$R *.dfm}
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,math,ExtCtrls;
 
type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
 
    procedure FormCreate(Sender: TObject);
  private
    { Déclarations privées }
    teta:integer;
    pos:Tpoint;
    function IsTrueType(Font: TFont): Boolean;
    function CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
    procedure TexteAngle(AString: string;ACanvas:TCanvas;Font:TFont;x,y:integer;d:integer);
    Function rotationpoint(xo,yo:integer;tetadeg:real;pt:Tpoint):Tpoint;
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
function TForm1.IsTrueType(Font: TFont): Boolean;
var DC: HDC;
    C : TBitmap;
    Metrics: TTextMetric;
begin
  C := TBitmap.create;
  try
    C.canvas.Font := Font;
    DC := GetDC(0);
    try
    C.Canvas.Handle := DC;
    C.Canvas.Font := Font;
    GetTextMetrics(C.Canvas.Handle, Metrics );
    Result := ( Metrics.tmPitchAndFamily and tmpf_TrueType ) = tmpf_TrueType;
    C.Canvas.Handle := 0;
    finally
      ReleaseDC(0, DC);
    end;
  finally
    C.Free;
  end;
end;
 
function TForm1.CreateRotatedFont(Font: TFont; Angle: Integer): HFont;
var
  LogFont: TLogFont;
begin
  If not IsTrueType(Font) then Font.Name:='Arial';
  FillChar(LogFont, SizeOf(LogFont), 0);
  with LogFont do begin
    lfHeight := Font.Height;
    lfWidth := 0;
    lfEscapement := Angle * 10;
    lfOrientation :=1;
    if fsBold in Font.Style then lfWeight := FW_BOLD
    else lfWeight := FW_NORMAL;
    lfItalic := Ord(fsItalic in Font.Style);
    lfUnderline := Ord(fsUnderline in Font.Style);
    lfStrikeOut := Byte(fsStrikeOut in Font.Style);
    lfCharSet := Byte(Font.Charset);
    StrPCopy(lfFaceName, Font.Name);
    lfQuality := DEFAULT_QUALITY;
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case Font.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LogFont);
end;
 
procedure TForm1.TexteAngle(AString: string;ACanvas:TCanvas;Font:TFont;x,y:integer;d:integer); //angle en degres
begin
  ACanvas.Font := Font;
  with ACanvas do
  begin
   Brush.style:=bsclear;
   Font.Handle := CreateRotatedFont(Font, d);
   TextOut(X, Y, AString);
  end;
end;
 
Function TForm1.rotationpoint(xo,yo:integer;tetadeg:real;pt:Tpoint):Tpoint;
var
    teta:real;
    Rayon:integer;
    fi: real;
begin
teta:=(pi*tetadeg/180);
if pt.x-xo<>0 then
fi:=arctan2(pt.y-yo,pt.x-xo)
else fi:=-pi/2;
Rayon:=round(sqrt(sqr(pt.x-xo)+sqr(pt.y-yo)));
result:=point(Round(xo+Rayon*cos(teta+fi)),Round(yo+Rayon*sin(teta+fi)));
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
width:=screen.Width;
height:=screen.Height;
position:=poscreencenter;
 
with font do begin
Size:=15;
Name:='arial';
style:=[fsbold];
end;
 
Pos:=point(clientwidth div 6,clientheight div 2);
end;
 
procedure TForm1.FormPaint(Sender: TObject);
var i:integer;
begin
for i:=1 to 36  do begin
inc(teta,10);
texteangle('Bonjour à toi',canvas,font,rotationpoint(clientwidth div 2,clientheight div 2,teta,pos).X,rotationpoint(clientwidth div 2,clientheight div 2,teta,pos).Y,-teta);
end;
end;
end.

merci pour ton intervention, je regarde ton boulot ;)
pour mon code, j'avais besoin de faire tourner un aimant droit sur lui-même en précisant le pôle nord et sud dessus et faire tourner les caractères N et S...
Maintenant, ça marche.
Pour l'aimant, je fais tourné un tableau de points et j'ai adopté la méthode précédente pour les caractères. Mais effectivement, ce n'est pas pratique pour placer correctement les caractères vu x,y coin en haut à gauche...
les caractères doivent être symétriques par rapport au centre de la rotation...
ton complément va donc être bien utile...

salut