Largeur texte

Salut,

"reno"

Est il possible d'obtenir (en fonction de la police et du corps) la largeur
d'une chine dans un controle texte ou étiquette afin de l'ajuster auto

Tu te débrouille en VBA ?


Option Compare Database
Option Explicit

Type Size
cx As Long
cy 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 Size) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Function LgTexte(Texte As String, Police As String, _
Taille As Double, Optional Gras As Boolean, Optional Italique As Boolean)

Dim hFont As Long
Dim hDC As Long
Dim TSize As Size
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 LgTexte = CVErr(xlErrValue): Exit Function
If hFont = 0 Then LgTexte = 0: Exit Function
SelectObject hDC, hFont
GetTextExtentPoint32A hDC, Texte, Len(Texte), TSize
DeleteObject hFont
ReleaseDC 0, hDC
LgTexte = TSize.cx

End Function



--
A+
Pierre (3stone) Access MVP
~~~~~~~~~~~~~~~~~~~~~~~
http://users.skynet.be/mpfa
http://users.skynet.be/accesshome

Je me debrouille suffisament pour utiliser cette supêrbe fonction mais
surement pas pour l'ecrire Merci à toi

Salut,

"reno"

Est il possible d'obtenir (en fonction de la police et du corps) la largeur
d'une chine dans un controle texte ou étiquette afin de l'ajuster auto

Tu te débrouille en VBA ?


Option Compare Database
Option Explicit

Type Size
cx As Long
cy 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 Size) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Function LgTexte(Texte As String, Police As String, _
Taille As Double, Optional Gras As Boolean, Optional Italique As Boolean)

Dim hFont As Long
Dim hDC As Long
Dim TSize As Size
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 LgTexte = CVErr(xlErrValue): Exit Function
If hFont = 0 Then LgTexte = 0: Exit Function
SelectObject hDC, hFont
GetTextExtentPoint32A hDC, Texte, Len(Texte), TSize
DeleteObject hFont
ReleaseDC 0, hDC
LgTexte = TSize.cx

End Function



--
A+
Pierre (3stone) Access MVP
~~~~~~~~~~~~~~~~~~~~~~~
http://users.skynet.be/mpfa
http://users.skynet.be/accesshome