Public Type POINTAPI
X As Long
Y As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const DEFAULT_CHARSET As Byte = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Public Function TailleChaineEcran(ByVal sChaine As String, ByVal sPolice As String, ByVal iTaille As Integer, Optional ByVal bBold As Boolean = False) As POINTAPI
Dim pt As POINTAPI, mWnd As Long, WR As RECT, nDC As Long
Dim TextSize As POINTAPI, CX As Long, CY As Long
Dim sNomChamp As String
Dim hEnCours As Long
' position curseur
GetCursorPos pt
' handle fenetre sous le curseur
mWnd = WindowFromPoint(pt.X, pt.Y)
' device context de la fenetre
nDC = GetWindowDC(mWnd)
Dim hFont As Long
hFont = CreateMyFont(sPolice, iTaille, bBold)
hEnCours = SelectObject(nDC, hFont)
' dimensions du texte dans sChaine
GetTextExtentPoint32 nDC, sChaine, Len(sChaine), TextSize
TailleChaineEcran.X = TextSize.X
TailleChaineEcran.Y = TextSize.Y
SelectObject nDC, hEnCours
hEnCours = ReleaseDC(mWnd, nDC)
End Function
Function CreateMyFont(sPolice As String, nSize As Integer, Optional bBold As Boolean = False) As Long
'Créer la police spécifique
CreateMyFont = CreateFont(-nSize, 0, 0, 0, FW_NORMAL + IIf(bBold, FW_BOLD, 0), False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sPolice)
End Function
.
