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

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 LOGPIXELSY = 90
' /* FONT WEIGHT (BOLD) VALUES */
Private Const FW_DONTCARE = 0
Private Const FW_NORMAL = 400
Private Const FW_GRAS = 700
Private Const FW_BOLD = 700
' /* FONT CHARACTER SET */
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
' /* Font OutPrecision */
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_TT_PRECIS = 4
Private Const OUT_TT_ONLY_PRECIS = 7
' /* Font clip precision */
Private Const CLIP_DEFAULT_PRECIS = 0
' /* Font Quality */
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
Private Const NONANTIALIASED_QUALITY = 3
Private Const ANTIALIASED_QUALITY = 4
Private Const CLEARTYPE_QUALITY = 5
Private Const CLEARTYPE_NATURAL_QUALITY = 6
         
Private Const DEFAULT_PITCH = 0
Private Const FF_ROMAN = 16
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_EFFECTS = &H100&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_NOSCRIPTSEL = &H800000
Private Const REGULAR_FONTTYPE = &H400
Private Const LF_FACESIZE = 32
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40