[RESOLVED] Adjust Font Size of Label to Completly Fill Control
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
Re: Adjust Font Size of Label to Completly Fill Control
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).
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Re: Adjust Font Size of Label to Completly Fill Control
Here, I had a bit of fun throwing this together:
Code:
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".
Code:
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
Last edited by Elroy; Jan 22nd, 2018 at 03:39 PM.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Re: Adjust Font Size of Label to Completly Fill Control
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.
Code:
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
Re: [RESOLVED] Adjust Font Size of Label to Completly Fill Control
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
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Re: [RESOLVED] Adjust Font Size of Label to Completly Fill Control
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)
Code:
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.