Удаление стилей

Sub LeaveLegalStyles()
'Leaves only legal styles in doc
Dim ist As Long
Dim stn As String
Dim stnewas As String
Dim nsav As Long
Dim scpos As Long
Dim nren As Long
Dim ndel As Long
Dim bf As Boolean
Dim stt As Style
Dim usedtemplate As String
Dim ad As Document
Dim ast As Document
Dim nst As Long
Dim delstyles() As String
Dim idels As Long
Dim ndels As Long

Dim view_all, view_field_codes, view_mode
Dim opt_repag_mode As Boolean
Dim alerts_mode As Boolean
Dim scrupd_mode As Boolean
Dim okRun As Boolean

'Show all characters and field codes
view_all = ActiveWindow.ActivePane.View.ShowAll
view_field_codes = ActiveWindow.View.ShowFieldCodes
view_mode = ActiveWindow.View.Type
opt_repag_mode = Application.Options.Pagination
alerts_mode = Application.DisplayAlerts
scrupd_mode = Application.screenupdating

Application.screenupdating = False
Application.DisplayAlerts = False
ActiveWindow.ActivePane.View.ShowAll = True
ActiveWindow.View.ShowFieldCodes = True
ActiveWindow.View.Type = wdNormalView
Application.Options.Pagination = False

nren = 0
ndel = 0
nsav = 0
okRun = True

'.0 Is the docread-only?
If ActiveDocument.ReadOnly Then
    MsgBox "Error: the document is in read-only state which prevents managing document's styles"
    okRun = False
    GoTo e_LLS
End If

'1. Check style template
Set ad = ActiveDocument
Set ast = ActiveDocument.AttachedTemplate.OpenAsDocument
ad.Activate
usedtemplate = Application.Dialogs(wdDialogToolsTemplates).template
If Not File_Exists(usedtemplate) Then
    MsgBox "The used template associated to the document is " & vbCrLf & _
    usedtemplate & vbCrLf & _
    "This file is not found by this path in the current computer." & vbCrLf & _
    "The style check is canceled."
    okRun = False
    GoTo e_LLS
End If

'2. Rename styles having ";" in their names
nsav = 0
nst = ad.Styles.Count

For ist = 1 To nst
    Set st = ad.Styles(ist)
    stn = st.NameLocal
    scpos = InStr(stn, ";") 'this separating character may depend on Windows Local Settings
    If scpos > 1 Then
        stnew = GetHead(stn, ";")
        On Error Resume Next
        st.NameLocal = stnew
        nren = nren + 1
        nsav = 0
        ActiveDocument.AttachedTemplate.Saved = True
        ActiveDocument.Save
        On Error GoTo 0
    End If
    Set st = Nothing
Next ist

'3. Search for illegal styles ( a) non-builtin; b) not used in the doc; c) not found in the style template)
idels = 0
ndels = 0
Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst

For ist = 1 To nst
    Set st = ad.Styles(ist)
    stn = st.NameLocal
    If Not (stn = "") Then
        If (Not st.BuiltIn) Then
            bf = FindStyle(stn) 'search something in this style inthe document
            If Not bf Then
                Set stt = Nothing
                On Error Resume Next
                Set stt = ast.Styles(stn)
                On Error GoTo 0
                If (stt Is Nothing) Then
                    On Error Resume Next
                    idels = idels + 1
                    ReDim Preserve delstyles(1 To idels)
                    delstyles(idels) = stn
                End If
            Else
                Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst
            End If
        End If
    End If
    Set st = Nothing
Next ist
ndels = idels

'Deleting illegal styles
If ndels > 0 Then
    nsav = 0
    For idels = 1 To ndels
        Set st = ad.Styles(delstyles(idels))
            On Error Resume Next
            'st.Delete
            ActiveDocument.Styles(delstyles(idels)).Delete
            On Error GoTo 0
            nsav = nsav + 1
            If nsav > 10 Then
                ActiveDocument.AttachedTemplate.Saved = True
                nsav = 0
                ActiveDocument.Save
                ActiveDocument.UndoClear
            End If

        Set st = Nothing
    Next idels
End If

e_LLS:
On Error Resume Next
ast.Close savechanges:=wdDoNotSaveChanges
Set ast = Nothing
ad.Activate
Set ad = Nothing

If okRun Then
    MsgBox "Renamed: " & CStr(nren) & " styles;" & vbCrLf & "Deleted: " & CStr(ndels) & " styles."
End If

End Sub