excelvba

Auto Size Text To Fit Shape via vba

Please run the following code.

Sub Macro1()

'Delete all shapes
For i = ActiveSheet.Shapes.Count To 1 Step -1
    ActiveSheet.Shapes(i).Delete
Next i

'Add rectangle
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left:=50, Width:=100, Top:=50, Height:=40)
    .TextFrame2.MarginLeft = 0
    .TextFrame2.MarginRight = 0
    .TextFrame2.MarginTop = 0
    .TextFrame2.MarginBottom = 0
    .TextFrame2.VerticalAnchor = msoAnchorMiddle
    .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    .TextFrame2.TextRange.Font.Size = 30
    .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
    .TextFrame2.TextRange.Characters.Text = "Stackoverflow"
End With

End Sub

The following picture shows my question.

enter image description here

Thanks in advance

Solution

  • Can you try this?

    Sub Test()
    Dim i As Long, myShp As Shape
    
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        ActiveSheet.Shapes(i).Delete
    Next i
    
    Set myShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left:=50, Width:=100, Top:=50, Height:=40)
    
    With myShp
        .TextFrame2.MarginLeft = 0
        .TextFrame2.MarginRight = 0
        .TextFrame2.MarginTop = 0
        .TextFrame2.MarginBottom = 0
        .TextFrame2.VerticalAnchor = msoAnchorMiddle
        .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .TextFrame2.TextRange.Font.Size = 1
        .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
        .TextFrame2.TextRange.Characters.Text = "Stackoverflow"
        .TextFrame2.WordWrap = msoFalse
        
        Do While .TextFrame2.TextRange.BoundWidth < myShp.Width
          .TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size + 1
        Loop
    End With
End Sub