在 MS Word 中遍历段落并修剪空格

Question

I need to create a macros which removes whitespaces and indent before all paragraphs in the active MS Word document. I've tried following:

For Each p In ActiveDocument.Paragraphs
    p.Range.Text = Trim(p.range.Text)
Next p

which sets macros into eternal loop. If I try to assign string literal to the paragraphs, vba always creates only 1 paragraph:

For Each p In ActiveDocument.Paragraphs
    p.Range.Text = "test"
Next p

I think I have a general misconception about paragraph object. I would appreciate any enlightment on the subject.

Answer 1

The reason the code in the question is looping is because replacing one paragraph with the processed (trimmed) text is changing the paragraphs collection. So the code will continually process the same paragraph at some point.

This is normal behavior with objects that are getting deleted and recreated "behind the scenes". The way to work around it is to loop the collection from the end to the front:

For i = ActiveDocument.Paragraphs.Count To 1 Step -1
    Set p = ActiveDocument.Paragraphs(i)
    p.Range.Text = Trim(p.Range.Text)
Next

That said, if the paragraphs in the document contain any formatting this will be lost. String processing does not retain formatting.

An alternative would be to check the first character of each paragraph for the kinds of characters you consider to be "white space". If present, extend the range until no more of these characters are detected, and delete. That will leave the formatting intact. (Since this does not change the entire paragraph a "normal" loop works.)

Sub TestTrimParas()
    Dim p As Word.Paragraph
    Dim i As Long
    Dim rng As Word.Range

    For Each p In ActiveDocument.Paragraphs
        Set rng = p.Range.Characters.First
        'Test for a space or TAB character
        If rng.Text = " " Or rng.Text = Chr(9) Then
            i = rng.MoveEndWhile(" " + Chr(9))
            Debug.Print i
            rng.Delete
        End If
    Next p
End Sub

Answer 2

You could, of course, do this in a fraction of the time without a loop, using nothing fancier than Find/Replace. For example:

Find = ^p^w
Replace = ^p

and

Find = ^w^p
Replace = ^p

As a macro this becomes:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  .InsertBefore vbCr
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = False
    .Text = "^p^w"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^w^p"
    .Execute Replace:=wdReplaceAll
  End With
  .Characters.First.Text = vbNullString
End With
Application.ScreenUpdating = True
End Sub

Note also that trimming text the way you're doing is liable to destroy all intra-paragraph formatting, cross-reference fields, and the like; it also won't change indents . Indents can be removed by selecting the entire document and changing the paragraph format; better still, modify the underlying Styles (assuming they've been used correctly).

Answer 3

Entering "eternal" loop is a bit unpleasant. Only Chuck Norris can exit one. Anyway, try to make a check before trimming and it will not enter:

Sub TestMe()

    Dim p As Paragraph
    For Each p In ThisDocument.Paragraphs
        If p.Range <> Trim(p.Range) Then p.Range = Trim(p.Range)
    Next p

End Sub

Answer 4

As has been said by @Cindy Meister, I need to prevent endless creation of another paragraphs by trimming them. I bear in mind that paragraph range contains at least 1 character, so processing range - 1 character would be safe. Following has worked for me

Sub ProcessParagraphs()
    Set docContent = ActiveDocument.Content

    ' replace TAB symbols throughout the document to single space (trim does not remove TAB)
    docContent.Find.Execute FindText:=vbTab, ReplaceWith:=" ", Replace:=wdReplaceAll

    For Each p In ActiveDocument.Paragraphs

        ' delete empty paragraph (delete operation is safe, we cannot enter enternal loop here)
        If Len(p.range.Text) = 1 Then
            p.range.Delete

        ' remove whitespaces
        Else
            Set thisRg = p.range
            ' shrink range by 1 character
            thisRg.MoveEnd wdCharacter, -1
            thisRg.Text = Trim(thisRg.Text)
        End If

        p.LeftIndent = 0
        p.FirstLineIndent = 0
        p.Reset
        p.range.Font.Reset

    Next

    With Selection
        .ClearFormatting
    End With
End Sub

Answer 5

I saw a number of solutions here are what worked for me. Note I turn off track changes and then revert back to original document tracking status.

I hope this helps some.

Option Explicit

Public Function TrimParagraphSpaces()
       
    Dim TrackChangeStatus: TrackChangeStatus = ActiveDocument.TrackRevisions
    ActiveDocument.TrackRevisions = False
    
    Dim oPara As Paragraph
    For Each oPara In ActiveDocument.StoryRanges(wdMainTextStory).Paragraphs
        Dim oRange As Range: Set oRange = oPara.Range
        Dim endRange, startRange As Range
        
        Set startRange = oRange.Characters.First
        Do While (startRange = Space(1))
            startRange.Delete 'Remove last space in each paragraphs
            Set startRange = oRange.Characters.First
        Loop
    
        Set endRange = oRange
        ' NOTE: for end range must select the before last characted. endRange.characters.Last returns the chr(13) return
        endRange.SetRange Start:=oRange.End - 2, End:=oRange.End - 1
        Do While (endRange = Space(1))
            'endRange.Delete 'NOTE delete somehow does not work for the last paragraph
            endRange.Text = "" 'Remove last space in each paragraphs
            Set endRange = oPara.Range
            endRange.SetRange Start:=oRange.End - 1, End:=oRange.End
        Loop
     Next
     
    ActiveDocument.TrackRevisions = TrackChangeStatus
End Function