diff --git a/winword/migration.vba b/winword/migration.vba new file mode 100644 index 0000000..c256dce --- /dev/null +++ b/winword/migration.vba @@ -0,0 +1,170 @@ +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 \ No newline at end of file