vba 处理特定段落前的表观空行中的分页符

存在 word 文档另存为 wps 时，出现页码变多，与 word 中的不一致的情况。对于其中的某页标题行前有空行，空行内包含分页符与前面的文字在同一段落。需要删除改分页符，同时使原标题段落格式（大纲级别，编号，下划线等）不变，还要使其不上提到前一页。

Rem Attribute VB_Name = "ProcessSelectedParagraphs"
Sub ProcessSelectedParagraphs()
'
' 终极版：处理选定段落的分页符、空行及标题排版
' 1. 智能处理标题前的分页符/换行符 (保护标题样式，防止误删段落标记)
' 2. 自动删除完全空白的页面
' 3. 替换段落内部分页符
'
    Dim para As Paragraph
    Dim i As Long
    Dim deletedCount As Long
    Dim pageBreaksReplaced As Long
    Dim emptyPagesDeleted As Long
    Dim report As String
    Dim undoRecord As undoRecord
    
    deletedCount = 0
    pageBreaksReplaced = 0
    emptyPagesDeleted = 0
    report = "处理结果报告:" & vbCrLf & vbCrLf
    
    ' 创建撤销记录
    Set undoRecord = Application.undoRecord
    undoRecord.StartCustomRecord "智能排版处理"
    
    Application.ScreenUpdating = False
    
    ' ==========================================================================================
    ' 第一步：倒序遍历，处理分页符替换和标题规则
    ' ==========================================================================================
    For i = Selection.Paragraphs.Count To 1 Step -1
        Set para = Selection.Paragraphs(i)
        Dim paraText As String
        paraText = para.Range.text
        
        ' --- 规则 A: 标题行处理 ---
        ' 如果是标题行 (大纲级别 1-9)
        If IsHeading(para) Then
            Dim prevPara As Paragraph
            Set prevPara = para.Previous
            If Not prevPara Is Nothing Then
                Dim prevRng As Range
                Set prevRng = prevPara.Range
                Dim prevText As String
                prevText = prevRng.text
                
                ' 检查前一段是否包含分页符
                Dim hasPageBreak As Boolean
                hasPageBreak = (InStr(prevText, Chr(12)) > 0)
                
                ' 情况1: 前一段是纯粹的分页符/空行 (例如只有 ^m^p 或 ^p)
                If IsJustBreak(prevText) Then
                    ' 再次确认不是图片
                    If prevRng.InlineShapes.Count = 0 And prevRng.ShapeRange.Count = 0 Then
                        prevRng.Delete
                        deletedCount = deletedCount + 1
                        
                        ' 【关键修正】如果删除了分页符，为了保持标题在页首，
                        ' 将标题段落设置为"段前分页"
                        If hasPageBreak Then
                            para.Format.PageBreakBefore = True
                        End If
                    End If
                
                ' 情况2: 前一段包含文本，但末尾有分页符 (Text...^m^p)
                ' 策略：只删除分页符(^m)，保留段落标记(^p)，同时设置标题段前分页
                ElseIf hasPageBreak Then
                    With prevRng.Find
                        .ClearFormatting
                        .text = "^m"
                        .Replacement.text = "" ' 仅移除分页符
                        .Forward = True
                        .Wrap = wdFindStop
                        .Execute Replace:=wdReplaceAll
                    End With
                    
                    ' 【关键修正】显式分页符转为样式分页
                    para.Format.PageBreakBefore = True
                End If
            End If
        End If
        
        ' --- 规则 B: 替换段落内部的分页符 (非标题前的情况) ---
        ' 如果段落文本中包含分页符 (Chr(12))
        ' 注意：如果上面规则A已经处理了该段（作为某标题的前一段），这里可能会重复处理？
        ' 由于是倒序，当前 para 是 i。规则A处理的是 i-1。
        ' 所以当前 para (i) 如果含有分页符，说明它不是作为标题前缀被处理的（或者它本身就是标题但含有分页符）
        If InStr(para.Range.text, Chr(12)) > 0 Then
            Dim replaced As Long
            replaced = ReplacePageBreaksAdvanced(para.Range.Duplicate)
            If replaced > 0 Then
                pageBreaksReplaced = pageBreaksReplaced + replaced
            End If
        End If
    Next i

    
    ' ==========================================================================================
    ' 第二步：检测并删除空页 (全页为空行或不可见字符)
    ' ==========================================================================================
    Dim searchRange As Range
    Set searchRange = Selection.Range
    If Selection.Paragraphs.Count > 0 Then
        searchRange.Start = Selection.Paragraphs(1).Range.Start
        searchRange.End = Selection.Paragraphs(Selection.Paragraphs.Count).Range.End
    End If
    
    Dim pBreak As Range
    Set pBreak = searchRange.Duplicate
    
    With pBreak.Find
        .ClearFormatting
        .text = "^m"
        .Forward = True
        .Wrap = wdFindStop
        
        Do While .Execute
            Dim checkRange As Range
            Set checkRange = pBreak.Duplicate
            checkRange.Collapse wdCollapseEnd
            
            Dim nextBreakFinder As Range
            Set nextBreakFinder = searchRange.Document.Range(checkRange.Start, searchRange.End)
            
            Dim endOfPage As Long
            If nextBreakFinder.Find.Execute(FindText:="^m", Forward:=True, Wrap:=wdFindStop) Then
                endOfPage = nextBreakFinder.Start
            Else
                endOfPage = searchRange.End
            End If
            
            checkRange.End = endOfPage
            
            If IsRangeEmpty(checkRange) Then
                If checkRange.InlineShapes.Count = 0 And checkRange.ShapeRange.Count = 0 Then
                    Dim deleteRange As Range
                    Set deleteRange = searchRange.Document.Range(pBreak.Start, checkRange.End)
                    deleteRange.Delete
                    emptyPagesDeleted = emptyPagesDeleted + 1
                End If
            End If
            
            pBreak.Collapse wdCollapseEnd
            If pBreak.Start >= searchRange.End Then Exit Do
        Loop
    End With

    Application.ScreenUpdating = True
    undoRecord.EndCustomRecord
    
    report = report & "替换分页符: " & pageBreaksReplaced & vbCrLf
    report = report & "清理标题前分隔符: " & deletedCount & vbCrLf
    report = report & "删除空页: " & emptyPagesDeleted & vbCrLf
    
    MsgBox report, vbInformation, "处理完成"
End Sub

' ==========================================================================================
' 辅助函数
' ==========================================================================================

Function IsHeading(para As Paragraph) As Boolean
    IsHeading = (para.OutlineLevel >= wdOutlineLevel1 And para.OutlineLevel <= wdOutlineLevel9)
End Function

Function IsJustBreak(text As String) As Boolean
    ' 检查文本是否只包含 分页符、换行符、空白
    Dim temp As String
    temp = text
    temp = Replace(temp, Chr(13), "")
    temp = Replace(temp, Chr(12), "")
    temp = Replace(temp, Chr(11), "")
    temp = Replace(temp, " ", "")
    temp = Replace(temp, vbTab, "")
    temp = Replace(temp, ChrW(12288), "")
    temp = Replace(temp, Chr(160), "")
    IsJustBreak = (Len(temp) = 0)
End Function

Function IsRangeEmpty(rng As Range) As Boolean
    Dim txt As String
    txt = rng.text
    If Len(txt) > 5000 Then
        IsRangeEmpty = False
        Exit Function
    End If
    txt = Replace(txt, Chr(13), "")
    txt = Replace(txt, Chr(11), "")
    txt = Replace(txt, Chr(12), "")
    txt = Replace(txt, " ", "")
    txt = Replace(txt, vbTab, "")
    txt = Replace(txt, ChrW(12288), "")
    txt = Replace(txt, Chr(160), "")
    IsRangeEmpty = (Len(txt) = 0)
End Function

Function ReplacePageBreaksAdvanced(rng As Range) As Long
    Dim replaceCount As Long
    Dim findRange As Range
    replaceCount = 0
    If InStr(rng.text, Chr(12)) = 0 Then
        ReplacePageBreaksAdvanced = 0
        Exit Function
    End If
    Set findRange = rng.Duplicate
    With findRange.Find
        .ClearFormatting
        .text = "^m"
        .Replacement.text = "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = False
        Do While .Execute(Replace:=wdReplaceOne)
            replaceCount = replaceCount + 1
            findRange.Collapse wdCollapseEnd
            If findRange.Start >= rng.End Then Exit Do
        Loop
    End With
    ReplacePageBreaksAdvanced = replaceCount
End Function