Public Type RECT
 left As Long
 top As Long
 right As Long
 bottom As Long
End Type
 
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As _
  RECT) As Long
 
Public Type TSize
 cx As Long
 cy As Long
End Type
 
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" _
       (ByVal hdc As Long, ByVal lpsz As String, _
        ByVal cbString As Long, lpSize As TSize) As Long
 
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) _
  As Long
 
Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
       (ByVal Height As Long, ByVal Width As Long, ByVal Escapement As Long, _
        ByVal Orientation As Long, ByVal Weight As Long, ByVal Italic As Long, _
        ByVal Underline As Long, ByVal StrikeOut As Long, ByVal Ccharset As _
        Long, _
        ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, _
        ByVal FontName As String) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As _
  Long) As Long
 
Function TextExtent(Ctrl As Control, Text As String)
 Dim R As RECT, Size As TSize, Faktor As Single, hdc As Long, _
     hfont As Long, h_old As Long
 GetWindowRect Ctrl.Parent.hwnd, R
 Faktor = Ctrl.Parent.WindowHeight / (R.bottom - R.top)
 hfont = CreateFont(Ctrl.FontSize, 0, 0, 0, Ctrl.FontWeight, _
        Ctrl.FontItalic, Ctrl.FontUnderline, 0, 1, 0, 0, 0, 2, _
        Ctrl.FontName)
 hdc = GetDC(0)
 h_old = SelectObject(hdc, hfont)
 GetTextExtentPoint32 hdc, Text, Len(Text), Size
 SelectObject hdc, h_old
 ReleaseDC 0, hdc
 TextExtent = Size.cx * Faktor
End Function