An open mind, an open question…

Word VBA: Resize Text to Fit Text Boxes

80 words
Sub ResizeTextToFitTextBox()

    If Selection.StoryType <> wdTextFrameStory Then Exit Sub

    Dim myTextRange As Range
    Dim myShape As Shape

    Set myShape = Selection.ShapeRange(1)
    Set myTextRange = myShape.TextFrame.TextRange

    myTextRange.Font.Size = 2

    If myShape.TextFrame.Overflowing = True Then
        MsgBox "Even when set to a size of 2 points, the text overflows the textbox."
        Exit Sub
    End If

    Do Until myShape.TextFrame.Overflowing = True
        myTextRange.Font.Size = _
        myTextRange.Font.Size + 0.5

    myTextRange.Font.Size = _
    myTextRange.Font.Size - 0.5

End Sub