delete all styles but to keep the font, bold etc. format
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:
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.
Code:
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:
Code:
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
