Rotation de textes TrueType

Bonjour Sergio,
sergio a écrit :

Bonjour,

je souhaite écrire sur un PictureBox un texte quelconque sous un certain
angle.
Je me suis inspiré du code du site suivant :
http://vb.developpez.com/faq/?page=Graphisme#texte_inc
Malheureusement si ce code fonctionne bien avec une police 'Arial' ou 'Times
New Roman', il n'en est pas de même avec une police du type 'Webdings'.
Comment puis-je résoudre ce problème ?

Je pense que le problème vient du paramètre lfCharset qui n'est pas
renseigné dans l'exemple que tu indiques :

Arial, Times New Roman ... => DEFAULT_CHARSET ou ANSI_CHARSET
Webdings, WingDings ... => SYMBOL_CHARSET

Essaie (à adapter) :

Private Const LF_FACESIZE = 32
Private Const ANSI_CHARSET As Byte = 0
Private Const DEFAULT_CHARSET As Byte = 1
Private Const SYMBOL_CHARSET As Byte = 2

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900


Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type


Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long, ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long


Private Sub Command1_Click()
DrawText Me, "Je m'appelle", 40, 40, 2700, "Times New Roman"
DrawText Me, "Jacques93", 40, 160, 900, "Webdings", SYMBOL_CHARSET
End Sub


Private Sub DrawText(Pict As Object, Txt As String, _
X As Long, Y As Long, Angle As Long, _
Police As String, _
Optional Charset As Byte = DEFAULT_CHARSET)
Dim hFont As Long, OldHdc As Long
Dim lf As LOGFONT, lResult As Long


Pict.ScaleMode = vbPixels
With lf
.lfHeight = 20
.lfWidth = 10
.lfEscapement = Angle
.lfOrientation = Angle
.lfWeight = FW_NORMAL
.lfItalic = 0
.lfUnderline = True
.lfStrikeOut = 0
.lfOutPrecision = 2
.lfClipPrecision = 1
.lfQuality = 0
.lfPitchAndFamily = 0
.lfCharSet = Charset
.lfFaceName = Police & Chr$(0)
End With
hFont = CreateFontIndirect(lf)
OldHdc = SelectObject(Pict.hdc, hFont)


lResult = TextOut(Pict.hdc, X, Y, Txt, Len(Txt))
lResult = SelectObject(Pict.hdc, OldHdc)
lResult = DeleteObject(hFont)
End Sub

--
Cordialement,

Jacques.

Rebonjour,

SUPER !! Merci Jacques.
Vous êtes toujours d'un bon secours !

Bonne journée.
Serge

"Jacques93" wrote:

Bonjour Sergio,
sergio a écrit :
> Bonjour,
>
> je souhaite écrire sur un PictureBox un texte quelconque sous un certain
> angle.
> Je me suis inspiré du code du site suivant :
> http://vb.developpez.com/faq/?page=Graphisme#texte_inc
> Malheureusement si ce code fonctionne bien avec une police 'Arial' ou 'Times
> New Roman', il n'en est pas de même avec une police du type 'Webdings'.
> Comment puis-je résoudre ce problème ?
>

Je pense que le problème vient du paramètre lfCharset qui n'est pas
renseigné dans l'exemple que tu indiques :

Arial, Times New Roman ... => DEFAULT_CHARSET ou ANSI_CHARSET
Webdings, WingDings ... => SYMBOL_CHARSET

Essaie (à adapter) :

Private Const LF_FACESIZE = 32
Private Const ANSI_CHARSET As Byte = 0
Private Const DEFAULT_CHARSET As Byte = 1
Private Const SYMBOL_CHARSET As Byte = 2

Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900


Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type


Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long, ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long


Private Sub Command1_Click()
DrawText Me, "Je m'appelle", 40, 40, 2700, "Times New Roman"
DrawText Me, "Jacques93", 40, 160, 900, "Webdings", SYMBOL_CHARSET
End Sub


Private Sub DrawText(Pict As Object, Txt As String, _
X As Long, Y As Long, Angle As Long, _
Police As String, _
Optional Charset As Byte = DEFAULT_CHARSET)
Dim hFont As Long, OldHdc As Long
Dim lf As LOGFONT, lResult As Long


Pict.ScaleMode = vbPixels
With lf
.lfHeight = 20
.lfWidth = 10
.lfEscapement = Angle
.lfOrientation = Angle
.lfWeight = FW_NORMAL
.lfItalic = 0
.lfUnderline = True
.lfStrikeOut = 0
.lfOutPrecision = 2
.lfClipPrecision = 1
.lfQuality = 0
.lfPitchAndFamily = 0
.lfCharSet = Charset
.lfFaceName = Police & Chr$(0)
End With
hFont = CreateFontIndirect(lf)
OldHdc = SelectObject(Pict.hdc, hFont)


lResult = TextOut(Pict.hdc, X, Y, Txt, Len(Txt))
lResult = SelectObject(Pict.hdc, OldHdc)
lResult = DeleteObject(hFont)
End Sub

--
Cordialement,

Jacques.

sergio a écrit :

Rebonjour,

SUPER !! Merci Jacques.
Vous êtes toujours d'un bon secours !

Bonne journée.
Serge

Merci du retour, et du petit mot sympa :-)

--
Cordialement,

Jacques.