Size the text in a textbox to fill the textbox

Article contributed by Bill Coan

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