Sub Demo()
Dim SBar As Boolean, oShp As Shape, i As Long, j As Long
With Application
  .ScreenUpdating = False
  SBar = .DisplayStatusBar
  .DisplayStatusBar = True
End With
For Each oShp In ActiveDocument.Shapes
  With oShp
    i = .Anchor.Information(wdActiveEndPageNumber)
    If i <> j Then
      StatusBar = "Processing page: " & i
      j = i
    End If
    If .Type = msoTextBox Then
      Do While .TextFrame.Overflowing
        .TextFrame.TextRange.Font.Shrink
      Loop
    End If
  End With
Next
With Application
  .StatusBar = False
  .DisplayStatusBar = SBar
  .ScreenUpdating = True
End With
End Sub