You could use a pair of on-entry and on-exit macros such as:
Code:
Sub FldExit()
Application.ScreenUpdating = False
Dim sTxtWdth As Single, sFldWdth As Single, sPrnWdth As Single
sFldWdth = InchesToPoints(2.5)
With ActiveDocument.FormFields(1).Range
With .Sections(1).PageSetup
sPrnWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
sTxtWdth = .Characters.Last.Previous.Information(wdHorizontalPositionRelativeToPage)
sTxtWdth = sTxtWdth - .Characters.First.Information(wdHorizontalPositionRelativeToPage)
Do While .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
.Characters.First.Information(wdVerticalPositionRelativeToPage)
.Font.Scaling = sFldWdth / (sTxtWdth + sPrnWdth) * 100
Loop
If sTxtWdth > sFldWdth Then .Font.Scaling = sFldWdth / sTxtWdth * 100
End With
Application.ScreenUpdating = True
End Sub
Sub FldEntry()
ActiveDocument.FormFields(1).Range.Font.Scaling = 100
End Sub