Word 删除未使用样式删除样式但保留格式

Posted 2021-06-28 笑虾

移除样式并保留格式

Sub 移除样式并保留格式()
 '不能完全保留格式
 'https://sspai.com/post/38852
 '对于一个由多文档合并起来的长文档，它的样式多而混乱以致于无法使用，会引起word崩溃
 '对于这些样式，移除（即都统一为正文样式），并保留各种格式（变成不受样式控制的直接格式）
     Dim Para As Paragraph
     Dim Fnt As Font '代码字体的所有格式
     Dim Pfmt As ParagraphFormat '代表段落的所有格式
     For Each Para In ActiveDocument.Paragraphs
         With Para
             If .Style <> ActiveDocument.Styles("正文") Then '如果不是正文样式，则开始处理
                Set Fnt = .Style.Font '获得段落样式的所有字体属性，赋给fnt
                Set Pfmt = .Style.ParagraphFormat '获得段落样式的所有段落属性，赋给pfmt
                .Style = ActiveDocument.Styles("正文") '把它的样式改为正文
                .Range.Font = Fnt '为改变样式后的段落设置回原来的字体属性
                .Range.ParagraphFormat = Pfmt '为改变样式后的段落设置回原来的段落属性
             End If
         End With
     Next
 End Sub

删除未使用样式

Sub DeleteUnusedStyles()
' 报错时直接忽略，继续执行后续代码
On Error Resume Next
'出错跳转
On Error GoTo ErrorHandler
    Dim oStyle As Style
    For Each oStyle In ActiveDocument.Styles
        '只检查非内置样式
        'If oStyle.BuiltIn = False Then
            With ActiveDocument.Content.Find
                .ClearFormatting
                .Style = oStyle.NameLocal
                .Execute FindText:="", Format:=True
                If .Found = False Then
                    oStyle.Delete
                End If
            End With
        'End If
    Next oStyle
End Sub

别一个版本来源于：https://zhuanlan.zhihu.com/p/306579510

Sub 删除未使用样式organizerdelete()
'https://word.tips.net/T001337_Removing_Unused_Styles.html

On Error GoTo ErrorHandler
Dim oStyle As Style, i&
i = 0
For Each oStyle In ActiveDocument.Styles
    'If oStyle.BuiltIn = False Then
        With ActiveDocument.Content.Find
            .ClearFormatting
            .MatchWildcards = False
            .Style = CVar(oStyle.NameLocal)
            .Execute FindText:="", Format:=True
            If Not .Found Then
                Application.OrganizerDelete _
                Source:=ActiveDocument.Path & "\\" & ActiveDocument.Name, _
                Name:=oStyle.NameLocal, Object:=wdOrganizerObjectStyles
                i = i + 1
            End If
        End With
    'End If
Next oStyle
MsgBox "共删除" & i & "未使用样式"

Exit Sub '退出过程

'发生错误时处理
ErrorHandler:
    i = i - 1 '发生一次错误则减1
    Resume Next

End Sub