Reset font while preserving character-styled formatting

[Leigh Webber]

After a quick Google, I couldn't find any macro for resetting font
formatting while preserving character-styled text. Big document. Important
stuff is styled, including character styles. Want to clear out all direct
font formatting. Ctrl+A, Ctrl+Spacebar nukes my character-styled formatting.
:-(

The cure:
========================================
Public Sub ResetChar()
'Redefines Word's ResetChar command to preserve character style

'Removes all direct character formatting except
'for ranges with character styles
Dim laoRange() 'dynamic array of character-styled ranges and style
names
Dim loStyleRange As Range
Dim loStyle As Style
Dim i As Integer
Dim loOriginalRange As Range

ReDim laoRange(2, 0) 'First dimension is range, second is style name

'For each character style in the document..
For Each loStyle In ActiveDocument.Styles
If loStyle.Type = wdStyleTypeCharacter Then
'Find all occurrences of the style
If loStyle.InUse Then
'Ignore the default paragraph font
If loStyle <> "Default Paragraph Font" Then
'loStyleRange will be the range that the
'Find.Execute method locates.

'If the selection is an insertion point, do the current
word.
'Otherwise, just process the selection
If Selection.Type = wdSelectionIP Then
Set loStyleRange = Selection.Words(1)
Else
Set loStyleRange = Selection.Range.Duplicate
End If

'Remember the original range
Set loOriginalRange = loStyleRange.Duplicate

With loStyleRange.Find
'Set up the Find to find style only
.ClearFormatting
.Text = ""
.Style = loStyle
'Repeatedly execute the find
Do
.Execute Format:=True
If .Found Then
'We found a range that has this character
style.
'(loStyleRange now points to the found text)
'Add this range to the array
Debug.Print loStyleRange.Start,
loStyleRange.End, loStyleRange.Text
'Resize the array
ReDim Preserve laoRange(2, UBound(laoRange,
2) + 1)
'Set the first element to a dup of the found
range
Set laoRange(1, UBound(laoRange, 2)) =
loStyleRange.Duplicate
'Put the style name in the second element
laoRange(2, UBound(laoRange, 2)) =
loStyle.NameLocal
'Repeat
End If '.found
Loop Until Not .Found
End With
End If 'loStyle <> "Default Paragraph Font"
End If 'loStyle.InUse
End If 'loStyle.Type = wdStyleTypeCharacter
Next loStyle
'Reset font formatting for the original range
loOriginalRange.Font.Reset
'Reapply the character styles
For i = 1 To UBound(laoRange, 2)
Set loStyleRange = laoRange(1, i)
loStyleRange.Style = laoRange(2, i)
Next i
End Sub
=========================================

 

[Jean-Guy Marcil]

Leigh Webber was telling us:
Leigh Webber nous racontait que :

After a quick Google, I couldn't find any macro for resetting font
formatting while preserving character-styled text. Big document.
Important stuff is styled, including character styles. Want to clear
out all direct font formatting. Ctrl+A, Ctrl+Spacebar nukes my
character-styled formatting. :-(

Thanks for sharing...
Very cleverly done!

--
Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Leigh Webber]

Oops. Found a bug. Here's the corrected version:
=============================================
Public Sub ResetChar()
'Redefines Word's ResetChar command to preserve character style

'Removes all direct character formatting except
'for ranges with character styles
Dim laoRange() 'dynamic array of character-styled ranges and style
names
Dim loStyleRange As Range
Dim loStyle As Style
Dim i As Integer
Dim loOriginalRange As Range
Dim loLastFoundRange As Range

ReDim laoRange(2, 0) 'First dimension is range, second is style name

'Remember the original range
If Selection.Type = wdSelectionIP Then
Set loOriginalRange = Selection.Words(1).Duplicate
Else
Set loOriginalRange = Selection.Range.Duplicate
End If

'Initialize loLastFoundRange (see below)
Set loLastFoundRange = loOriginalRange.Duplicate

'For each character style in the document..
For Each loStyle In ActiveDocument.Styles
If loStyle.Type = wdStyleTypeCharacter Then
'Find all occurrences of the style
If loStyle.InUse Then
'Ignore the default paragraph font
If loStyle <> "Default Paragraph Font" Then
'loStyleRange will be the range that the
'Find.Execute method locates.

'If the selection is an insertion point, do the current
word.
'Otherwise, just process the selection
If Selection.Type = wdSelectionIP Then
Set loStyleRange = Selection.Words(1)
Else
Set loStyleRange = Selection.Range.Duplicate
End If

With loStyleRange.Find
'Set up the Find to find style only
.ClearFormatting
.Text = ""
.Style = loStyle
'Repeatedly execute the find
Do
'loLastFoundRange is needed to avoid a loop (see
below)
Set loLastFoundRange = loStyleRange.Duplicate
.Execute Format:=True
If .Found Then
'We found a range that has this character
style.
'(loStyleRange now points to the found text)
'Add this range to the array
'Resize the array
ReDim Preserve laoRange(2, UBound(laoRange,
2) + 1)
'Set the first element to a dup of the found
Range
Set laoRange(1, UBound(laoRange, 2)) =
loStyleRange.Duplicate
'Put the style name in the second element
laoRange(2, UBound(laoRange, 2)) =
loStyle.NameLocal
End If '.found
'Repeat -- but there's a glitch: in some
situations, the
'Find keeps finding the same range. Detect that
and bail out
'if necessary.
Loop Until (Not .Found) Or ((loStyleRange.Start =
loLastFoundRange.Start) And _
(loStyleRange.End =
loLastFoundRange.End))
End With
End If 'loStyle <> "Default Paragraph Font"
End If 'loStyle.InUse
End If 'loStyle.Type = wdStyleTypeCharacter
Next loStyle
'Reset font formatting for the original range
loOriginalRange.Font.Reset
'Reapply the character styles
For i = 1 To UBound(laoRange, 2)
Set loStyleRange = laoRange(1, i)
loStyleRange.Style = laoRange(2, i)
Next i
End Sub
=============================================