#1
|
|||
|
|||
How to resize a paragraph range to include just a single line of text
I frequently work on documents with strict page limits. To meet these limits, I condense text to nix "runts," those one- or two-word ends of paragraphs that appear on a single line. Meanwhile, I need to return all of the lines in the paragraph to no condensing, except for the one or two lines that, when condensed, cause the runt to disappear.
The process: I'm writing a macro to automate the process, as follows:
Code:
.Expand Unit:=wdLine Thanks Code:
Sub SqueezeText_1012() ' rngEndPara identifies the end of the paragraph, then passes it to another ' variable (lngLastLineNum); this is so we can determine if a condensed ' paragraph has shrunk by a line Dim rngEndPara As Range ' rngPara is used to apply the condensing and subsequent line-by-line ' resetting to no condensing Dim rngPara As Range Dim lngLastLineNum As Long ' Used to increment the condense loop by 0.05 intervals Dim iCondense As Single ' Set the initial range as the current cursor position (Selection.Range) Set rngPara = Selection.Range ' Expand the range to include the entire paragraph rngPara.Expand Unit:=wdParagraph ' If there is already condensed/expanded text in the paragraph, set it to ' none; do this early on, or else the end point might be set on one line, ' then, after nixing consensing, the end point is on a different line rngPara.Font.Spacing = 0 ' Set the initial range as the current cursor position (Selection.Range) Set rngEndPara = Selection.Range ' Expand the range to include the entire paragraph rngEndPara.Expand Unit:=wdParagraph ' Collapse the rngEndPara range to the end of the range so we can eventually ' get the line number it's on With rngEndPara .Collapse direction:=wdCollapseEnd ' Because collapsing a paragraph range sets the range to AFTER the ' paragraph mark, back it up a character .MoveEnd Unit:=wdCharacter, Count:=-1 End With ' Set this last-paragraph-line marker lngLastLineNum = rngEndPara.Information(wdFirstCharacterLineNumber) ' Condense the full paragraph range: ' Set the incrementer to -0.05 (point) iCondense = -0.05 ' Now loop until either the paragraph shrinks one line or we hit a max. ' 0.2 pt condensed Do Until rngEndPara.Information(wdFirstCharacterLineNumber) = lngLastLineNum - 1 Or rngPara.Font.Spacing = -0.2 rngPara.Font.Spacing = iCondense ' Condense in -0.05 increments iCondense = iCondense + -0.05 Loop ' If after condensing 0.2 point the paragraph's total line count doesn't ' decrease, then the paragraph isn't a candidate for condensing, so reset ' the spacing to 0. If lngLastLineNum = rngEndPara.Information(wdFirstCharacterLineNumber) Then rngPara.Font.Spacing = 0 End If ' Set the range to just a single line; start at the first line of the paragraph With rngPara .Collapse direction:=wdCollapseStart .Expand Unit:=wdLine End With End Sub |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 10-12-2018 at 03:26 PM. Reason: Code refinement |
#3
|
|||
|
|||
Wow, this is terrific -- thank you, Paul!
It never occurred to me that you could determine the spatial position of text on a page -- cool stuff! |
#4
|
|||
|
|||
Hi Paul,
Thanks again for your generous help on this macro last year. I've found that I need to more selectively use it, on a per-paragraph-only basis, without looping through an entire document, and I'm trying to extract just the meat of the macro from the loop through all paragraphs, so I can select just a paragraph and run the macro, but I'm stumped by something: In the macro, it looks like you are using an attribute of the current paragraph -- the character number at the end -- to control the loop, as follows: Code:
Do While .End < Para.Range.End Thanks! |
#5
|
||||
|
||||
Replace:
Code:
For Each Sctn In ActiveDocument.Sections 'Loop through each Section With Sctn 'Get the Section print width With .PageSetup Code:
With Selection 'Get the Section print width With .Sections.First.PageSetup Code:
Next
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#6
|
|||
|
|||
Fantastic -- many thanks for your help!
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Highlighting applied to range ending in a paragraph continues to apply to text added after | Peterson | Word VBA | 2 | 10-08-2018 02:50 PM |
Pasted text becomes single long line | qaz1 | Word | 1 | 07-25-2015 04:13 AM |
Extract Line of Text w/ specific characters up to the paragraph character, send to Excel | dmarie123 | Word VBA | 10 | 07-20-2015 12:16 AM |
macro to add brackets to each line and add single quotes to each word in the line | bracketandquotes | Word VBA | 17 | 02-16-2015 03:51 PM |
what is the professional way to include an equation in a paragraph? | Jamal NUMAN | Word | 1 | 07-07-2011 11:53 PM |