Change font size of controls at run time

Private Sub Form_Load()
a = "123"
MsgBox TextWidth(a)
b = "123456789"
MsgBox TextWidth(ba)


Text1.Width = TextWidth(Text1.Text) + (120)
End Sub

correction:
MsgBox TextWidth(b)
instead
MsgBox TextWidth(ba)

Something like this - make sure you use truetype fonts though - otherwise it might go bang.

There is one problem however. the font width cannot be changed without a similar change in font height, therefore, you must decide what you mean by fill a control. do you mean height or width or, as per my example function, either as long as all text can be seen.

Function FitText(ctl As Control, Optional Borderwidth As Long = 3)
'Border width in pixels
    Dim cw  As Single
    Dim ch  As Single
    Dim dw As Single
    Dim dh As Single
    Dim text As String
   
    Set Me.Font = ctl.Font
   
    On Error Resume Next
    text = ctl.text
    If Err <> 0 Then
        text = ctl.Caption
    End If
   
    If text = vbNullString Then Exit Function

    cw = ctl.Width - 2 * ScaleX(Borderwidth, vbPixels, ScaleMode)
    ch = ctl.Height - 2 * ScaleY(Borderwidth, vbPixels, ScaleMode)
    dw = cw / Me.TextWidth(text)
    dh = ch / Me.TextHeight(text)
   
    If dw < dh Then
        ctl.Font.Size = ctl.Font.Size * dw
    Else
        ctl.Font.Size = ctl.Font.Size * dh
    End If
   
    Me.Font = ctl.Font
    If TextWidth(text) > cw Or TextHeight(text) > ch Then
        FitText ctl, Borderwidth + 1
        Exit Function
    End If
    'Refresh
    ctl.SelStart = 0

End Function

Or slightly more efficient:

Function FitText(ctl As Control, Optional Borderwidth As Long = 3)
'Border width in pixels
    Dim cw  As Single
    Dim ch  As Single
    Dim dw As Single
    Dim dh As Single
    Dim text As String
   
    Set Me.Font = ctl.Font
   
    On Error Resume Next
    text = ctl.text
    If Err <> 0 Then
        text = ctl.Caption
    End If
   
    If text = vbNullString Then Exit Function

    cw = ctl.Width - 2 * ScaleX(Borderwidth, vbPixels, ScaleMode)
    ch = ctl.Height - 2 * ScaleY(Borderwidth, vbPixels, ScaleMode)
    dw = cw / Me.TextWidth(text)
    dh = ch / Me.TextHeight(text)
   
    If dw < dh Then
        Me.Font.Size = Me.Font.Size * dw
    Else
        Me.Font.Size = Me.Font.Size * dh
    End If
   
    If TextWidth(text) > cw Or TextHeight(text) > ch Then
        FitText ctl, Borderwidth + 1
        Exit Function
    End If
    'Refresh
    ctl.Font.Size = Me.Font.Size
    ctl.SelStart = 0

End Function

This doesn't seem to have worked..

I'm not bothered about height or width as long as all text can be seen.  

The controls caption can be mulitiple words upto a maximum of 30 characters.

Your example didn't seem to work it just kept the same font size.  I have looked through your code and everything looks ok, so I think it should have worked but have tyou tested it as part of an array which is what i'm using e.g

for i = 0 to buttons.count - 1
FitText buttons(i)
next i

I just tested it with the following code and it appeared fine. What font ae you using? I get much better results using "Microsoft Sans Serif" as opposed to the standard "MS Sans Serif" which is not True-Type.

Option Explicit

Private Sub Form_Load()
    Dim i As Integer
   
    For i = 0 To Command1.Count - 1
        FitText Command1(i), 4
    Next
End Sub

Function FitText(ctl As Control, Optional Borderwidth As Long = 3)
'Border width in pixels
    Dim cw  As Single
    Dim ch  As Single
    Dim dw As Single
    Dim dh As Single
    Dim text As String
   
    Set Me.Font = ctl.Font
   
    On Error Resume Next
    text = ctl.text
    If Err <> 0 Then
        text = ctl.Caption
    End If
   
    If text = vbNullString Then Exit Function

    cw = ctl.Width - 2 * ScaleX(Borderwidth, vbPixels, ScaleMode)
    ch = ctl.Height - 2 * ScaleY(Borderwidth, vbPixels, ScaleMode)
    dw = cw / Me.TextWidth(text)
    dh = ch / Me.TextHeight(text)
   
    If dw < dh Then
        Me.Font.Size = Me.Font.Size * dw
    Else
        Me.Font.Size = Me.Font.Size * dh
    End If
   
    If TextWidth(text) > cw Or TextHeight(text) > ch Then
        FitText ctl, Borderwidth + 1
        Exit Function
    End If
    'Refresh
    ctl.Font.Size = Me.Font.Size
    ctl.SelStart = 0

End Function

I have changed to a Microsoft Sans Serif font but still no joy.  It just slows down the loading process of the specific form.

here is the code i am using incase it's me that is causing the problem

Dim rs As Recordset
Dim cn As Connection
Dim sql As String


Set cn = New Connection
cn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Sys.mdb;"
Set rs = New Recordset
sql = "Select * from [mainscreen] "
rs.Open sql, cn
rs.MoveFirst
For i = 0 To buttons.Count
buttons(i).Caption = rs![description]
buttons(i).BackColor = rs![color]
FitText buttons(i), 2     <<<<<<  Your function
If buttons(i).Caption = "Not Configured" Then buttons(i).Visible = False
rs.MoveNext
Next i
rs.Close
cn.Close

Thanks fds,

It did work on a new project, just not on the project I was working on.  I didn't actually try it on a control array but it worked for a single control calling the function at the on load event.

I think it may be that my original project does various calls at the on load event and some of these calls relay screen resolutions, once this information is gathered it resizes the controls of the form depending on the resolution.

There was a simple solution to this, but I didn't really want to go down that route but it's to late now....

Set the maximum text to 25 when the user is configuring their controls and set the font size of the control to 8 at runtime.

It seems to have worked.

I will award you the points as your solution does what I required.

Thanks for your help