Автоматический подбор размера шрифта для TextBox

Option Compare Database
Option Explicit
 
Private 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 GetDeviceCaps Lib "gdi32" _
   (ByVal hdc As Long, ByVal nIndex As Long) As Long
 Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
    Alias "GetTextExtentPoint32A" _
    (ByVal hdc As Long, ByVal lpsz As String, _
     ByVal cbString As Long, lpSize As SIZE) As Long
 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, lParam As Any) As Long
 Private Declare Function SelectObject Lib "gdi32" _
   (ByVal hdc As Long, ByVal hObject As Long) As Long
 Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" _
    (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 DeleteObject Lib "gdi32" _
   (ByVal hObject As Long) As Long
  
'*********************************************************
'Назначение:Уменьшает фонт контрола в текстбоксе в отчете, если
    'текст "не влезает" в него, до тех пор пока не "влезет"
     'или размер шрифта не станет равен 5.
    'На основе примера Игоря Макеева
    'http://am.rusimport.ru/MsAccess/f2.aspx?id=3284
 'am v1.0.0_030207_14:31:18
'http://am.rusimport.ru
'mailto:a_mitin@mail.ru
 '*********************************************************
Public Function SetFont(tb As Variant) As Boolean
 On Error GoTo Err_
Dim dc As Long
Dim lPixelPerInchX As Long, lbwt As Long, lbwp As Long
 Dim lPixelPerInchY As Long
Dim lFont As Long, lFontOld As Long, splen As Long
 Dim spleny As Long
Dim sz As SIZE
Dim lH As Long
 Const LOGPIXELSY = 90
Const LOGPIXELSX = 88

Dim lNewSize As Long
     dc = GetDC(0)
    lPixelPerInchX = GetDeviceCaps(dc, LOGPIXELSX)
    lPixelPerInchY = GetDeviceCaps(dc, LOGPIXELSY)
    Do
        If lNewSize = 0 Then
             lNewSize = tb.FontSize
        Else
            lNewSize = lNewSize - 1
        End If
        lFont = CreateFont(-(lNewSize * lPixelPerInchY) / 72, _
                            0, 0, 0, tb.FontWeight, 0, 0, 0, _
                           1, 0, 0, 0, 2, tb.FontName)
        lFontOld = SelectObject(dc, lFont)
        GetTextExtentPoint32 dc, "Ж", 1, sz
         splen = sz.cx
        spleny = sz.cy \ 3
        GetTextExtentPoint32 dc, tb.Value, Len(tb.Value), sz
        SelectObject dc, lFontOld
        DeleteObject lFont
         Dim lk As Long
        If sz.cy = 0 Then
            lk = 1
        Else
           lk = (tb.Height \ ((sz.cy + spleny) / lPixelPerInchY * 1440))
        End If
         If lk = 0 Then lk = 1
        lbwt = ((sz.cx) / lPixelPerInchX) * 1440 / lk
        lH = sz.cy
     Loop Until (lbwt < tb.Width Or lNewSize <= 5)
    If tb.FontSize <> lNewSize Then tb.FontSize = lNewSize
 Ex_:
    ReleaseDC 0, dc
    Exit Function
Err_:
    MsgBox Err.Description ' Err "Module1.SetFont"
    Resume Ex_
 End Function