Сжать текст в текстовом поле без переноса

Question

Я вставил текстовое поле под вставкой -> фигуры ----> Текстовое поле. Теперь я хочу изменить размер шрифта текстового поля, если текстовое поле переполнено. Я попробовал следующие коды.

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