清楚书签文本并保留书签

Sub ClearBookmarkTextSafe()
    Dim doc As Document
    Dim bm As Bookmark
    Dim arrNames() As String
    Dim arrRanges() As Object
    Dim i As Long, n As Long
    Dim t As Double
    Dim oldScreenUpdating As Boolean
    Dim oldDisplayAlerts As Boolean
    Dim oldTrackRevisions As Boolean
 
    On Error GoTo CleanUp
    t = Timer
    Set doc = ActiveDocument
    n = doc.Bookmarks.Count
 
    If n = 0 Then
        MsgBox "文档中没有书签。", vbInformation
        Exit Sub
    End If
 
    ' ===== 保存原始设置并关闭性能杀手 =====
    oldScreenUpdating = Application.ScreenUpdating
    oldDisplayAlerts = Application.DisplayAlerts
    oldTrackRevisions = doc.TrackRevisions
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    doc.TrackRevisions = False      ' 关键！关掉修订模式
    ' =======================================
 
    ' 先全部缓存到数组，避免遍历集合时修改集合
    ReDim arrNames(1 To n)
    ReDim arrRanges(1 To n)
    i = 0
    For Each bm In doc.Bookmarks
        i = i + 1
        arrNames(i) = bm.Name
        Set arrRanges(i) = bm.Range.Duplicate   ' Duplicate 创建独立副本
    Next bm
 
    ' 批量处理
    For i = 1 To n
        ' 仅处理非空书签（有文本的才清空）
        If arrRanges(i).Start < arrRanges(i).End Then
            arrRanges(i).Text = ""
        End If
        doc.Bookmarks.Add Name:=arrNames(i), Range:=arrRanges(i)
 
        ' 每100个释放一次控制权，防止界面假死
        If i Mod 100 = 0 Then
            Application.StatusBar = "正在处理: " & i & " / " & n
            DoEvents
        End If
    Next i
 
    MsgBox "完成！共处理 " & n & " 个书签，耗时 " & Format(Timer - t, "0.0") & " 秒。", vbInformation
 
CleanUp:
    On Error Resume Next
    Application.ScreenUpdating = oldScreenUpdating
    Application.DisplayAlerts = oldDisplayAlerts
    doc.TrackRevisions = oldTrackRevisions
    Application.StatusBar = False
End Sub