Microsoft Office Forums - View Single Post - [Solved] How to resize a paragraph range to include just a single line of text

macropod · 10-12-2018, 02:59 PM

Try the following approach. As coded, the macro tests every multi-line paragraph and, if that paragraph's last line is less than 1/6 of the print width, condenses the paragraph font spacing in 0.05pt increments till the line wrapping disappears. Each line is then re-set and, if it wraps, is recondensed as much as needed. Condensing never exceeds 1pt; you can change that by changing the -1 in the code. You can also change the 1/6 criteria to another value (e.g. 1/5 or 1/7) by changing the 6 in the code.

Code:

Sub MinimizeLastLineWraps()
Application.ScreenUpdating = False
Dim Sctn As Section, Para As Paragraph, Rng As Range, RngTmp As Range, sWdth As Single, sSpc As Single
For Each Sctn In ActiveDocument.Sections
  'Loop through each Section
  With Sctn
    'Get the Section print width
    With .PageSetup
      sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
    End With
    'Loop through each Paragraph in the Section
    For Each Para In .Range.Paragraphs
      With Para
        Set Rng = .Range
        With Rng
          'Reset the font spacing to 0
          sSpc = 0: .Font.Spacing = sSpc
          'Check whether the paragraph has more than one line; skip one-liners.
          If .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
            .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary) Then
            'Check how far along the line the last character is; we only want to process short last lines.
            'Compress paragraphs with short last lines, up to 1pt.
            Do While .Characters.Last.Information(wdHorizontalPositionRelativeToTextBoundary) < sWdth / 6
              'If the compression exceeds 1pt, re-set & give up.
              If sSpc = -1 Then
                sSpc = 0: .Font.Spacing = sSpc: Exit Do
              End If
              sSpc = sSpc - 0.05: .Font.Spacing = sSpc
            Loop
            If sSpc <> 0 Then
              'Re-check whether the paragraph has more than one line; skip one-liners.
              If .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
                .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary) Then
                'Decompress each line, then apply minimal re-compression to restore then to one line each
                .Collapse wdCollapseStart
                Set RngTmp = .Duplicate
                Do While .End < Para.Range.End
                  Set RngTmp = RngTmp.GoTo(What:=wdGoToLine, Which:=wdGoToNext)
                  .End = RngTmp.Start
                  sSpc = 0: .Font.Spacing = sSpc
                  Do While .Characters.First.Information(wdVerticalPositionRelativeToTextBoundary) <> _
                    .Characters.Last.Information(wdVerticalPositionRelativeToTextBoundary)
                    sSpc = sSpc - 0.05: .Font.Spacing = sSpc
                  Loop
                  .Collapse wdCollapseEnd
                Loop
              End If
            End If
          End If
        End With
      End With
    Next
  End With
Next
Application.ScreenUpdating = True
End Sub