Type SDimTexte
Largeur As Long
Hauteur As Long
End Type
Private Declare Function GetDC Lib "User32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateFontA Lib "Gdi32" _
(ByVal H As Long, ByVal W As Long, ByVal E As Long, _
ByVal O As Long, ByVal W As Long, ByVal I As Long, _
ByVal u As Long, ByVal S As Long, ByVal C As Long, _
ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "Gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32A Lib "Gdi32" _
(ByVal hDC As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As SDimTexte) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
'____________________________________________________________
Private Function DimTexte(Texte As String, Police As String, _
Taille As Double, Optional Gras As Boolean, _
Optional Italique As Boolean) As SDimTexte
Dim hFont As Long, hDC As Long
Dim PixpInch As Double
hDC = GetDC(0)
PixpInch = GetDeviceCaps(hDC, 90) / 72
hFont = CreateFontA(-Taille * PixpInch, 0, 0, 0, _
400 - 300 * Gras, -Italique, 0, 0, 1, 0, 0, 0, 0, Police)
If hFont = 0 Then
ReleaseDC 0, hDC
DimTexte.Largeur = 0
DimTexte.Hauteur = 0
Else
SelectObject hDC, hFont
GetTextExtentPoint32A hDC, Texte, Len(Texte), DimTexte
DeleteObject hFont
ReleaseDC 0, hDC
End If
End Function