[RESOLVED] Adjust Font Size of Label to Completly Fill Control

[Hassan Basri]

Hello Everybody,

My application already adjusts control sizes and positions automatically depending on the users display and form size. However my issue is with the font size. My application queries the users computer system and retreives the current font used by the users theme. So the font can vary by different users.

Does anybody know if there is a way for adjusting the font size of the label such that it fills the user control as much as possible while keeping the entirety of the text within the bounds of the control? Thank you

[Elroy]

You'd have to jump through a couple of hoops, but you could use the .TextWidth property of your form. Or, if you can't change the font of your form, put an invisible picturebox on your form that's used for nothing but this.

Basically, set form (or picturebox) to have same font and size as label, use .TextWidth to get its width, and then compare that to the label's width. You may also have to account for your label's border, but it's certainly doable.

Good Luck,
Elroy

EDIT1: If you couldn't change your label's width, you could keep reducing the font size until you found one that fit the text into the label (all using the above outlined approach).

[Elroy]

Here, I had a bit of fun throwing this together:

Private Sub FixTextIntoLabel(sText As String, lbl As VB.Label, pic As VB.PictureBox, _
                             Optional nMinPoints As Single = 0!, Optional nMaxPoints As Single = 999999!)
    ' The pic is just a helper picturebox.  It's up to you to make sure it's invisible.
    ' You could change it to the form if you don't mind changing the font and scalemode on the form.
    '
    Dim lblWidth As Long
    Dim lPrevDirection As Long
    Dim nLastSize As Single
    Dim nPrevSize As Single
    Dim txtWidth As Long
    Dim nIncrease As Single
    Dim lErr As Long
    '
    lblWidth = lbl.Width / Screen.TwipsPerPixelX
    lblWidth = lblWidth - 2
    Select Case True
    Case lbl.Appearance = 1 And lbl.BorderStyle = 1
        lblWidth = lblWidth - 4
    Case lbl.BorderStyle = 1
        lblWidth = lblWidth - 2
    End Select
    '
    pic.ScaleMode = vbPixels
    If lbl.Font.Size > nMaxPoints Then lbl.Font.Size = nMaxPoints
    If lbl.Font.Size < nMinPoints Then lbl.Font.Size = nMinPoints
    Set pic.Font = lbl.Font
    '
    Err.Clear
    Do
        nIncrease = 0.5
        txtWidth = pic.TextWidth(sText)
        If txtWidth = lblWidth Then Exit Do
        If txtWidth < lblWidth Then
            If lPrevDirection = -1 Then Exit Do
            lPrevDirection = 1
            nLastSize = pic.Font.Size
            nPrevSize = pic.Font.Size
            Do
                If pic.Font.Size + nIncrease > nMaxPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        pic.Font.Size = pic.Font.Size + nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize < pic.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2
            Loop
        Else
            If lPrevDirection = 1 Then
                pic.Font.Size = nLastSize
                Exit Do
            End If
            lPrevDirection = -1
            nPrevSize = pic.Font.Size
            Do
                If pic.Font.Size - nIncrease < nMinPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        pic.Font.Size = pic.Font.Size - nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize > pic.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2
            Loop
            Debug.Print
        End If
        If lErr <> 0 Then Exit Do
    Loop
    '
    Set lbl.Font = pic.Font
    lbl.Caption = sText
End Sub

And I also attached a project with a demo.

Enjoy,
Elroy

EDIT1: I suppose I could have saved the ScaleMode and Font of the form, used the form for my work, and then restored the ScaleMode and Font. That would have obviated the need for the worker PictureBox. But I'll let others sort that if they like.

EDIT2: I went ahead and reworked it so that it didn't need the "worker picturebox".

Private Sub FixTextIntoLabel(sText As String, lbl As VB.Label, _
                             Optional nMinPoints As Single = 0!, Optional nMaxPoints As Single = 999999!)
    ' You could change it to the form if you don't mind changing the font on the form.
    '
    Dim lblWidth As Long
    Dim lPrevDirection As Long
    Dim nLastSize As Single
    Dim nPrevSize As Single
    Dim txtWidth As Long
    Dim nIncrease As Single
    Dim lErr As Long
    Dim frm As Form
    Dim frmOrigFont As Font
    Dim frmOrigScale As Long
    '
    Set frm = lbl.Parent
    Set frmOrigFont = frm.Font                              ' Save so we can restore.
    frmOrigScale = frm.ScaleMode                            ' Save so we can restore.
    '
    lblWidth = lbl.Width / Screen.TwipsPerPixelX
    lblWidth = lblWidth - 2&
    Select Case True
    Case lbl.Appearance = 1 And lbl.BorderStyle = 1
        lblWidth = lblWidth - 4&
    Case lbl.BorderStyle = 1
        lblWidth = lblWidth - 2&
    End Select
    '
    frm.ScaleMode = vbPixels
    If lbl.Font.Size > nMaxPoints Then lbl.Font.Size = nMaxPoints
    If lbl.Font.Size < nMinPoints Then lbl.Font.Size = nMinPoints
    Set frm.Font = lbl.Font
    '
    Err.Clear
    Do
        nIncrease = 0.5!
        txtWidth = frm.TextWidth(sText)
        If txtWidth = lblWidth Then Exit Do
        If txtWidth < lblWidth Then
            If lPrevDirection = -1 Then Exit Do
            lPrevDirection = 1
            nLastSize = frm.Font.Size
            nPrevSize = frm.Font.Size
            Do
                If frm.Font.Size + nIncrease > nMaxPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        frm.Font.Size = frm.Font.Size + nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize < frm.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2!
            Loop
        Else
            If lPrevDirection = 1 Then
                frm.Font.Size = nLastSize
                Exit Do
            End If
            lPrevDirection = -1
            nPrevSize = frm.Font.Size
            Do
                If frm.Font.Size - nIncrease < nMinPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        frm.Font.Size = frm.Font.Size - nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize > frm.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2!
            Loop
            Debug.Print
        End If
        If lErr <> 0 Then Exit Do
    Loop
    '
    Set lbl.Font = frm.Font
    lbl.Caption = sText
    '
    Set frm.Font = frmOrigFont              ' Put things back.
    frm.ScaleMode = frmOrigScale            ' Put things back.
End Sub

[Hassan Basri]

Hello Elroy, Thanks a lot for this sub-routine. It does exactly what I needed. Right out of the box your code is excellent. Thanks again.

[Hassan Basri]

Hello Elroy, after some testing I noticed the function wasn't working correctly in all situations. Namely where the width of the screen was much larger then the height. I added a check for TextHeight in addition to your TextWidth check. This solved the problem. Below is the updated code. Thanks again for your assistance.

Private Sub FixTextIntoLabel(sText As String, lbl As VB.Label, _
                             Optional nMinPoints As Single = 0!, Optional nMaxPoints As Single = 999999!)
    ' You could change it to the form if you don't mind changing the font on the form.
    '
    Dim lblWidth As Long
    Dim lblHeight As Long
    Dim lPrevDirection As Long
    Dim nLastSize As Single
    Dim nPrevSize As Single
    Dim txtWidth As Long
    Dim txtHeight As Long
    Dim nIncrease As Single
    Dim lErr As Long
    Dim frm As Form
    Dim frmOrigFont As Font
    Dim frmOrigScale As Long
    '
    Set frm = lbl.Parent
    Set frmOrigFont = frm.Font                              ' Save so we can restore.
    frmOrigScale = frm.ScaleMode                            ' Save so we can restore.
    '
    lblWidth = lbl.Width / Screen.TwipsPerPixelX
    lblHeight = lbl.Height / Screen.TwipsPerPixelY

    lblWidth = lblWidth - 2&
    lblHeight = lblHeight - 2&

    Select Case True
    Case lbl.Appearance = 1 And lbl.BorderStyle = 1
        lblWidth = lblWidth - 4&
    Case lbl.BorderStyle = 1
        lblWidth = lblWidth - 2&
    End Select
    '
    frm.ScaleMode = vbPixels
    If lbl.Font.Size > nMaxPoints Then lbl.Font.Size = nMaxPoints
    If lbl.Font.Size < nMinPoints Then lbl.Font.Size = nMinPoints
    Set frm.Font = lbl.Font
    '
    Err.Clear
    Do
        nIncrease = 0.5!
        txtWidth = frm.TextWidth(sText)
        txtHeight= frm.TextHeight(sText)
        If (txtWidth = lblWidth) Or (txtHeight = lblHeight) Then Exit Do
        If txtWidth < lblWidth Then
            If lPrevDirection = -1 Then Exit Do
            lPrevDirection = 1
            nLastSize = frm.Font.Size
            nPrevSize = frm.Font.Size
            Do
                If frm.Font.Size + nIncrease > nMaxPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        frm.Font.Size = frm.Font.Size + nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize < frm.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2!
            Loop
        Else
            If lPrevDirection = 1 Then
                frm.Font.Size = nLastSize
                Exit Do
            End If
            lPrevDirection = -1
            nPrevSize = frm.Font.Size
            Do
                If frm.Font.Size - nIncrease < nMinPoints Then
                    lErr = True
                Else
                    On Error Resume Next
                        frm.Font.Size = frm.Font.Size - nIncrease
                        lErr = Err
                    On Error GoTo 0
                End If
                If lErr <> 0 Then Exit Do
                If nPrevSize > frm.Font.Size Then Exit Do
                nIncrease = nIncrease + 0.2!
            Loop
            Debug.Print
        End If
        If lErr <> 0 Then Exit Do
    Loop
    '
    Set lbl.Font = frm.Font
    lbl.Caption = sText
    '
    Set frm.Font = frmOrigFont              ' Put things back.
    frm.ScaleMode = frmOrigScale            ' Put things back.
End Sub

[Elroy]

No problem. I didn't really exercise it thoroughly. If you're going to put it into production, I'd strongly recommend you run it through a few typical ways in which it'll be used.

Take Care,
Elroy

[KFVBF]

This can be simplified by calculating a scaling factor for resizing the font rather than using iteration and checking for fit.
Here's a basic example for fitting a CommandButton caption. This can be expanded a bit to universally apply to any control with a Text or Caption field.
This also uses a "dummy" Picturebox (Picture1)

Sub FitFont(c As CommandButton, Optional fudge As Single = 0.9)

With Picture1       'duplicate relevant font attributes to the dummy picturebox
       .Font = c.Font
       .FontSize = c.FontSize
       .Font.Bold = c.Font.Bold
       .FontItalic = c.FontItalic
      '.ScaleMode = me.ScaleMode 'just be sure that the picture box scalemode is the same as that used for the control
End With

CaptionORText$ = c.Caption 'the text to be scaled - caption or text depending on the type of control

'find a scale factor to make the font fit by comparing current size of the TEXT to the control size
vRatio = c.Height / Picture1.TextHeight(CaptionORText$)  'vertical - compare HEIGHTs
hRatio = c.Width / Picture1.TextWidth(CaptionORText$)  'horizontal - compare WIDTHs

'use the smaller of these ratios to scale text for fit WITHIN the control 
ScaleFactor = hRatio   
If hRatio < vRatio Then ScaleFactor = vRatio

'scale the font to fit
c.FontSize = c.FontSize * ScaleFactor * fudge   'the fudge factor is for appearance and to account for the control border, rounding, screen resolution  etc
'it could be a specifically calculated value based upon particular needs

End Sub

As a side note, in playing with resizing controls, I found some peculiar behaviors that result from built-in "autosizing" of controls, especially with regard to height.
These can be mostly avoided by the steps of (1) copying (saving) and deleting the Text/Caption of a control before (2) resizing the control, then (3) fitting the control font and (4) restoring the Text/Caption.