代码之家 › 专栏 › 技术社区 › Kram Kramer

通过vba自动调整文本大小以适应形状

vba excel

0

Kram Kramer · 技术社区 · 6 月前

请运行以下代码。

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

下图显示了我的问题。

提前感谢

2 回复 | 直到 6 月前

1

Haluk 6 月前

你能试试这个吗?

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

2

0

stack ninja 6 月前

您的宏代码已经包含“.TextFrame2.TextRange.Font.Size=30”。您可以将30更改为17或需要字体大小。