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