Maximum Font Size for Text Box

I need to have text as big as possible in a textbox.  I use the following code to try fitting the text until it's perfect.  The problem is that I have one very complex opentype font which takes a while each iteration and it's not moving quick enough.  How can I do this faster.  I played with the numbers a bit, but there must be some computation to help me get close to the right font size on the first try so I don't have to do so many loops.
Thanks

The object sent to these functions are my textbox

Public Function FontTooBig(obj As Object) As Boolean
    Dim WindowHandle As Long
    WindowHandle = obj.hWnd
    obj.SelStart = Len(obj.Text)
    LinesNotVisible = SendMessage(WindowHandle, EM_GETFIRSTVISIBLELINE, 0, 0)
    If LinesNotVisible <> 0 Then
        FontTooBig = True
    Else
        FontTooBig = False
    End If
End Function

Public Sub AdjustToFitFont(obj As Object)
    If obj.Text = "" Then
        Exit Sub
    End If
    Dim DecreasedFontSize As Boolean
    DecreasedFontSize = False
    While (FontTooBig(obj) Or obj.FontSize > PrefFontSize) And LinesNotVisible > 0
        obj.FontSize = obj.FontSize - IIf(obj.FontSize - (LinesNotVisible * 7) < 14, 3, (LinesNotVisible * 7))
        DecreasedFontSize = True
    Wend
   
    While (Not FontTooBig(obj) And obj.FontSize < PrefFontSize)
        obj.FontSize = obj.FontSize + IIf(DecreasedFontSize, 3, 7)
    Wend

    While (FontTooBig(obj) Or obj.FontSize > PrefFontSize)
        obj.FontSize = obj.FontSize - 1
        counter = counter + 1
    Wend
End Sub
Start Free Trial