delete all styles but to keep the font, bold etc. format

[ayltonasc]

I'm trying to figure out how to change the code below posted by
Paul Edstein answering a similar thread, but I cannot put the link below, so I'll post the name of the thread:
'Unwanted style name aliases in Word'

The similar thread was related to deleting the aliases from the name of the styles finishing with 'char' ou '* char'

the point is, I want almost the same thing, but instead of deleting just styles having '* char' in the name, I want to delete all styles, except the hard/internal ones, and I want to keep the format (bold, italic, font name and size, etc).

what I already tried:
in the sub DeleteCharCharStylesKeepFormatting I deleted the conditionals 'if' and the loop: 'do while', so I could free the code deleted all the styles and not only those with 'char' in their names. ...the rest of the code inside the 'functions' I didn't change because I guess nothing needed to be done.

I believe it's goes to an infinity loop in the text: .Execute from the code:

Do
With rngResult.Find
    .ClearFormatting
    .Style = sty
    .Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Execute
End With

below is the original code to delete the styles with the 'char' in their name, and in the end of the text I'll post the code that I changed, and of course, its not working.

Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
Do
    bCharCharFound = False
    For i = doc.Styles.Count To 1 Step -1
        Set sty = doc.Styles(i)
        sStyleName = sty.NameLocal
        If sStyleName Like "* Char*" Then
            bCharCharFound = True
            If sty.Type = wdStyleTypeCharacter Then
                Call StripStyleKeepFormatting(sty, doc)
                On Error Resume Next
                ' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
                sty.LinkStyle = wdStyleNormal
                sty.Delete
                Err.Clear
            Else
                sStyleReName = Replace(sStyleName, " Char", "")
                On Error Resume Next
                sty.NameLocal = sStyleReName
                If Err.Number = 5173 Then
                    Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
                    sty.Delete
                    Err.Clear
                Else
                    On Error GoTo ERR_HANDLER
                End If
            End If
            Exit For
        End If
        Set sty = Nothing
     Next i
Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & _
Err.Number & Chr(58) & Chr(32) & Err.Description, _
vbExclamation
End Sub

Function SwapStyles(ByRef styFind As Style, _
ByRef styReplace As Style, _
ByRef doc As Document)
With doc.Range.Find
    .ClearFormatting
    .Text = ""
    .Wrap = wdFindContinue
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Style = styFind
    .Replacement.ClearFormatting
    .Replacement.Style = styReplace
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
End With
End Function


Function StripStyleKeepFormatting(ByRef sty As Style, _
ByRef doc As Document)
Dim rngToSearch As Range
Dim rngResult As Range
Dim f As Font
Set rngToSearch = doc.Range
Set rngResult = rngToSearch.Duplicate
Do
    With rngResult.Find
        .ClearFormatting
        .Style = sty
        .Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Execute
    End With
If Not rngResult.Find.Found Then Exit Do
Set f = rngResult.Font.Duplicate
With rngResult
    .Font.Reset
    .Font = f
    .MoveStart wdWord
    .End = rngToSearch.End
End With
Set f = Nothing
Loop Until Not rngResult.Find.Found
End Function

modified code that I did something wrong below:

Sub DeleteCharCharStylesKeepFormatting( )
Dim sty As Style
Dim i As Integer
Dim doc As Document
Dim sStyleName As String
Dim sStyleReName As String
Dim bCharCharFound As Boolean
Set doc = ActiveDocument
'Do
    'bCharCharFound = False
    For i = doc.Styles.Count To 1 Step -1
        Set sty = doc.Styles(i)
        sStyleName = sty.NameLocal
        'If sStyleName Like "* Char*" Then
            'bCharCharFound = True
            'If sty.Type = wdStyleTypeCharacter Then
               Call StripStyleKeepFormatting(sty, doc)
               On Error Resume Next
                ' COMMENT OUT THE NEXT LINE IN WORD 2000 OR 97
                'sty.LinkStyle = wdStyleNormal(commented out because i'm using word 2000)
                sty.Delete
                Err.Clear
            'Else
                'sStyleReName = Replace(sStyleName, " Char", "")
                'On Error Resume Next
                'sty.NameLocal = sStyleReName
                'If Err.Number = 5173 Then
                   'Call SwapStyles(sty, doc.Styles(sStyleReName), doc)
                   ' sty.Delete
                   'Err.Clear
                   'Else
                   'On Error GoTo ERR_HANDLER
            'End If
        'End If
        'Exit For
    'End If
    Set sty = Nothing
'Next i
' Loop While bCharCharFound = True
Exit Sub
ERR_HANDLER:
MsgBox "An Error has occurred" & vbCr & Err.Number & Chr(58) & Chr(32) & Err.Description, vbExclamation
End Sub