VBA删除段落首尾空格和空白段落

tsgang

以下下程序在Word2003下运行通过，对选中段落有效。
可以把删除段首尾空格和空白行结合起来做个一键删空，效果不错。
全角和tab空格也能有效删除。
采用Word的查找替换功能，^p为段落标记，^w为空白标记。
对于段首空格，需要先插入一个辅助回车符。

Sub DelSpacesAheadPara()
'删除段首空格

    If Len(Selection.Text) < 2 Then Exit Sub
   
    On Error Resume Next
    Application.ScreenUpdating = False
   
    Dim rngSel As Range
    Set rngSel = Selection.Range
   
    rngSel.InsertBefore Text:=vbCrLf    '插入一个辅助回车符
    Call FindReplaceChar("^p^w", "^p", wdFindStop, bByte:=False)
    If Len(rngSel.Paragraphs(1).Range.Text) < 2 Then _
            rngSel.Paragraphs(1).Range.Delete    '删除辅助回车符
    rngSel.Select
   
    Application.ScreenUpdating = True
    Set rngSel = Nothing

End Sub

Sub DelSpacesBehindPara()
'删除段尾空格

    If Len(Selection.Text) < 2 Then Exit Sub
    On Error Resume Next
   
    Application.ScreenUpdating = False
    Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
    Application.ScreenUpdating = True

End Sub

Sub DelSpacesBoth()
'删除段尾空格

    If Len(Selection.Text) < 2 Then Exit Sub
    On Error Resume Next
   
    Dim rngSel As Range
    Set rngSel = Selection.Range
    Application.ScreenUpdating = False

    Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
    rngSel.InsertBefore Text:=vbCrLf
    Call FindReplaceChar("^p^w", "^p", wdFindStop, bByte:=False)
    If Len(rngSel.Paragraphs(1).Range.Text) < 2 Then _
            rngSel.Paragraphs(1).Range.Delete
    rngSel.Select
   
    Application.ScreenUpdating = True
    Set rngSel = Nothing

End Sub

Sub DelBlankPara()
'删空行和无内容的行

    If Len(Selection.Text) < 2 Then Exit Sub
  
    On Error Resume Next
    Application.ScreenUpdating = False
   
    Dim rngSel As Range
    Dim Para As Paragraph
    Set rngSel = Selection.Range
   
    For Each Para In rngSel.Paragraphs
        With Para
            If Len(Trim(.Range.Text)) = 1 Then
                .Range.Delete
            End If
        End With
        If rngSel.Paragraphs.Count = 1 Then Exit For   '避免死循环
    Next Para
    rngSel.Select
   
    Application.ScreenUpdating = True
    Set rngSel = Nothing
    Set Para = Nothing

End Sub

Private Sub FindReplaceChar(ByVal strFind As String, ByVal strReplace As String, _
    ByVal FindWrap As Integer, Optional ByVal bWild As Boolean = False, _
    Optional ByVal bByte As Boolean = True, Optional ByVal nReplace As Integer = wdReplaceAll)
'执行查找替换操作

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = strFind
        .Replacement.Text = strReplace
        .Forward = True
        .Wrap = FindWrap 'wdFindStop:停止,替换选定部分,若没选中则替换至文档末尾
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = bByte
        .CorrectHangulEndings = False
        .MatchWildcards = bWild
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=nReplace
    ActiveDocument.Activate
   
End Sub

[ 本帖最后由 tsgang 于 2010-2-7 22:20 编辑 ]

YZLSZAJ

谢谢LZ分享！

tangqingfu

谢谢楼主的分享，学习……

ke3088

Sub DelSpacesBehindPara()
'删除段尾空格

    If Len(Selection.Text) < 2 Then Exit Sub
     On Error Resume Next
     
    Application.ScreenUpdating = False
     Call FindReplaceChar("^w^p", "^p", wdFindStop, bByte:=False)
     Application.ScreenUpdating = True

End Sub
报告：Call FindReplaceChar，显示“子过程或函数未定义”