bagu-thesis/winword/migration.vba

Sub MapAndDeleteStyles()
    ' 样式映射字典
    ' 格式：源样式名称 -> 目标样式名称
    Dim styleMappings As Object
    Set styleMappings = CreateObject("Scripting.Dictionary")
    
    ' ===== 在这里配置你的样式映射关系 =====
    ' 示例：
    styleMappings.Add "Heading 1", "标题1"
    styleMappings.Add "Heading 2", "标题2"
    styleMappings.Add "Normal", "正文"
    styleMappings.Add "List Paragraph", "列表段落"
    styleMappings.Add "Caption", "题注"
    ' 添加更多映射...
    ' ====================================
    
    Dim srcStyleName As Variant
    Dim targetStyleName As String
    Dim srcStyle As Style
    Dim targetStyle As Style
    Dim doc As Document
    Dim para As Paragraph
    Dim rng As Range
    Dim styleExists As Boolean
    Dim convertedCount As Long
    
    Set doc = ActiveDocument
    convertedCount = 0
    
    ' 禁用屏幕更新以提高性能
    Application.ScreenUpdating = False
    
    ' 首先验证所有目标样式是否存在
    For Each srcStyleName In styleMappings.Keys
        targetStyleName = styleMappings(srcStyleName)
        On Error Resume Next
        Set targetStyle = doc.Styles(targetStyleName)
        On Error GoTo 0
        
        If targetStyle Is Nothing Then
            MsgBox "目标样式 '" & targetStyleName & "' 不存在于文档中！" & vbCrLf & _
                   "请先创建该样式或修改映射关系。", vbExclamation, "样式不存在"
            Application.ScreenUpdating = True
            Exit Sub
        End If
        Set targetStyle = Nothing
    Next srcStyleName
    
    ' 遍历文档中所有段落
    For Each para In doc.Paragraphs
        srcStyleName = para.Style.NameLocal
        
        ' 检查当前段落的样式是否需要映射
        If styleMappings.exists(srcStyleName) Then
            targetStyleName = styleMappings(srcStyleName)
            
            ' 应用目标样式
            para.Style = targetStyleName
            convertedCount = convertedCount + 1
        End If
    Next para
    
    ' 处理表格单元格内的文本（段落样式可能不同）
    Dim tbl As Table
    Dim cell As Cell
    For Each tbl In doc.Tables
        For Each cell In tbl.Range.Cells
            For Each para In cell.Range.Paragraphs
                srcStyleName = para.Style.NameLocal
                If styleMappings.exists(srcStyleName) Then
                    targetStyleName = styleMappings(srcStyleName)
                    para.Style = targetStyleName
                    convertedCount = convertedCount + 1
                End If
            Next para
        Next cell
    Next tbl
    
    ' 删除源样式
    Dim stylesToDelete As Object
    Set stylesToDelete = CreateObject("Scripting.Dictionary")
    
    For Each srcStyleName In styleMappings.Keys
        On Error Resume Next
        Set srcStyle = doc.Styles(srcStyleName)
        On Error GoTo 0
        
        If Not srcStyle Is Nothing Then
            ' 检查是否为内置样式（内置样式无法删除）
            If srcStyle.BuiltIn Then
                MsgBox "样式 '" & srcStyleName & "' 是Word内置样式，无法删除。" & vbCrLf & _
                       "已将其文本转换为目标样式，但样式本身保留。", vbInformation, "内置样式"
            Else
                stylesToDelete.Add srcStyleName, True
            End If
        End If
        Set srcStyle = Nothing
    Next srcStyleName
    
    ' 执行删除自定义样式
    Dim deleteCount As Long
    deleteCount = 0
    
    For Each srcStyleName In stylesToDelete.Keys
        On Error Resume Next
        Set srcStyle = doc.Styles(srcStyleName)
        On Error GoTo 0
        
        If Not srcStyle Is Nothing Then
            ' 检查是否还有任何内容使用该样式
            If Not IsStyleInUse(doc, srcStyleName) Then
                srcStyle.Delete
                deleteCount = deleteCount + 1
            Else
                MsgBox "样式 '" & srcStyleName & "' 可能仍被某些内容使用，无法安全删除。", _
                       vbExclamation, "样式仍在使用"
            End If
        End If
    Next srcStyleName
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 显示结果
    MsgBox "完成！" & vbCrLf & _
           "转换的段落/单元格数量: " & convertedCount & vbCrLf & _
           "删除的样式数量: " & deleteCount, vbInformation, "样式映射完成"
End Sub

' 辅助函数：检查样式是否还在文档中使用
Function IsStyleInUse(doc As Document, styleName As String) As Boolean
    Dim rng As Range
    Dim para As Paragraph
    
    ' 检查段落
    For Each para In doc.Paragraphs
        If para.Style.NameLocal = styleName Then
            IsStyleInUse = True
            Exit Function
        End If
    Next para
    
    ' 检查表格单元格
    Dim tbl As Table
    Dim cell As Cell
    For Each tbl In doc.Tables
        For Each cell In tbl.Range.Cells
            For Each para In cell.Range.Paragraphs
                If para.Style.NameLocal = styleName Then
                    IsStyleInUse = True
                    Exit Function
                End If
            Next para
        Next cell
    Next tbl
    
    ' 检查字符样式（直接应用在字符上）
    Dim charRng As Range
    Set rng = doc.Range
    With rng.Find
        .ClearFormatting
        .Style = styleName
        If .Execute(FindText:="") Then
            IsStyleInUse = True
            Exit Function
        End If
    End With
    
    IsStyleInUse = False
End Function