Resizing fonts in a text box

[catflap]

Hi



After a mail merge to a new document, I need to make sure all the text in a text box fits without overflowing. This I can achieve with the following code which loops though all the text boxes, checks if they overflow, and if so keeps reducing the font by one point until they fit:

Dim oShp As Shape
    For Each oShp In ActiveDocument.Shapes
        If oShp.Type = msoTextBox Then
            
            Do While ActiveDocument.Shapes(oShp.Name).TextFrame.Overflowing
                ActiveDocument.Shapes(oShp.Name).TextFrame.TextRange.Font.Size = ActiveDocument.Shapes(oShp.Name).TextFrame.TextRange.Font.Size - 1
            Loop
            
        End If
    Next

Things come unstuck however when the text box has more than one font size.

Does anyone know how I could loop though the lines in the text box (so I could resize them one at a time)? - there's only ever one font size per line, so this would work.

Or is there a better way maybe?