收缩文本框中的文本，不需要包覆

Question

我在insert--> shapes--> Textbox下插入了文本框，现在我想调整文本框的字体大小，如果文字溢出文本框。我尝试了以下代码。

With Selection
If .TextFrame.HorizontalOverflow = msoTrue Then
Do
.TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size - 1
Loop Until .TextFrame.HorizontalOverflow = msoFalse
End If

End with

ps:它的条形码字体。所以如果它被包裹，那么它是无法被条形码阅读器阅读，所以我想缩小它。

谢谢你

Answer 1

下面的代码似乎可以实现你所寻找的标准文本。 也许你可以提取原理，并将其用于你的条形码样式。

Option Explicit

Sub AdjustTextInTextBox()

    Dim myWs As Worksheet
    Set myWs = ThisWorkbook.ActiveSheet
    myWs.Shapes.AddShape msoTextBox, 100, 100, 250, 50

    Dim myShape As Shape
    Set myShape = myWs.Shapes.Item(1)
    myShape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText

    Dim myHeight As Long
    myHeight = myShape.Height

    myShape.TextFrame2.TextRange.Text = "Hello world its a really really really nice day"

    Do While myShape.Height > myHeight

        myShape.TextFrame2.TextRange.Font.Size = myShape.TextFrame2.TextRange.Font.Size - 1

    Loop

End Sub