CODEWITHSUNDEEP
vbaexcel
jpinto3912
jpinto3912

Reputation: 1465

Finding if a TextBox/Label caption fits in the control

The scenario is trying to adjust font size to get a nice graphic arrangement, or trying to decide where to break a caption/subtitle. a) In XL VBA is there a way to find out whether a text on a textbox, or caption on a label, still fits the control? b) Is there a way to know where was the text/caption broken on multiline control?

Upvotes: 1

Views: 2737

Answers (3)

Wayne Hoff
Wayne Hoff

Reputation: 1

This can be achieved by taking advantage of the label or textbox's .AutoSize feature, and looping through font sizes until you reach the one that fits best.

Public Sub ResizeTextToFit(Ctrl As MSForms.Label)   'or TextBox
    
    Const FONT_SHRINKAGE_FACTOR As Single = 0.9 'For more accuracy, use .95 or .99
    
    Dim OrigWidth As Single
    Dim OrigHeight As Single
    Dim OrigLeft As Single
    Dim OrigTop As Single
    
    With Ctrl
        If .Caption = "" Then Exit Sub
        .AutoSize = False
        OrigWidth = .Width
        OrigHeight = .Height
        OrigLeft = .Left
        OrigTop = .Top
        Do
            .AutoSize = True
            If .Width <= OrigWidth And .Height <= OrigHeight Then
                Exit Do     'The font is small enough now
            .Font.Size = .Font.Size * FONT_SHRINKAGE_FACTOR
            .AutoSize = False
        Loop
        .AutoSize = False
        .Width = OrigWidth
        .Height = OrigHeight
        .Left = OrigLeft
        .Top = OrigTop
    End With

End Sub

Upvotes: 0

jpinto3912
jpinto3912

Reputation: 1465

I gave this a rest, gave it enough back-of-head time (which produces far better results than "burp a non-answer ASAP, for credits"), and...

Function TextWidth(aText As String, Optional aFont As NewFont) As Single
    Dim theFont As New NewFont
    Dim notSeenTBox As Control

    On Error Resume Next 'trap for aFont=Nothing
    theFont = aFont 'try assign

    If Err.Number Then 'can't use aFont because it's not instantiated/set
        theFont.Name = "Tahoma"
        theFont.Size = 8
        theFont.Bold = False
        theFont.Italic = False
    End If
    On Error GoTo ErrHandler

    'make a TextBox, fiddle with autosize et al, retrive control width
    Set notSeenTBox = UserForms(0).Controls.Add("Forms.TextBox.1", "notSeen1", False)
    notSeenTBox.MultiLine = False
    notSeenTBox.AutoSize = True 'the trick
    notSeenTBox.Font.Name = theFont.Name
    notSeenTBox.SpecialEffect = 0
    notSeenTBox.Width = 0 ' otherwise we get an offset (a ""feature"" from MS)
    notSeenTBox.Text = aText
    TextWidth = notSeenTBox.Width
    'done with it, to scrap I say
    UserForms(0).Controls.Remove ("notSeen1")
    Exit Function

ErrHandler:
    TextWidth = -1
    MsgBox "TextWidth failed: " + Err.Description
End Function

I feel I'm getting/got close to answer b), but I'll give it a second mind rest... because it works better than stating "impossible" in a flash.

Upvotes: 3

dbb
dbb

Reputation: 2877

I'm sure there is no way to do this with the ordinary Excel controls on the Forms toolbar, not least because (as I understand it) they are simply drawings and not full Windows controls.

The simplest approach may be to make a slightly conservative estimate of the maximum text length for each control, through a few tests, and use these to manage your line breaks.

Upvotes: 0

Related Questions