Reset font skipping fields

[David Turner]

The code below is supposed to step through each paragraph in the document and
reset the character font unless the paragraph is a hyperlink field or
contains a hyperlink field. If it is a hyperlink field, it should be not be
reset, and if it contains a hyperlink field, the macro should test whether
each Word is a field and finally whether each character is a field, skipping
over the field range and resetting the rest.
I tried to use the InRange method but it doesn't seem to work for some
reason. Can anyone see what's wrong? Any help would be greatly appreciated.

Regards,
David Turner

Sub JumpHyperlinks()

Dim rPrg As Paragraph ' a paragraph
Dim rWrd As Range ' a word
Dim rChr As Range ' a character
Dim dupFont As Font ' font duplicate in range

Dim aField As Field
Dim fldRange As Range

For Each rPrg In ActiveDocument.Paragraphs
If rPrg.Range.Hyperlinks.Count = 0 Then
Set dupFont = rPrg.Range.Font.Duplicate
rPrg.Range.Font.Reset
rPrg.Range.Font = dupFont
ElseIf rPrg.Range.Hyperlinks.Count > 0 Then
For Each aField In rPrg.Range.Fields
Set fldRange = aField.Result
If Not rPrg.Range.InRange(fldRange) Then
For Each rWrd In rPrg.Range.Words
If rWrd.Hyperlinks.Count = 0 Then
Set dupFont = rWrd.Font.Duplicate
rWrd.Font.Reset
rWrd.Font = dupFont
ElseIf rWrd.Hyperlinks.Count > 0 Then
If Not rWrd.InRange(fldRange) Then

For Each rChr In rWrd.Characters
If rChr.Hyperlinks.Count = 0 Then
Set dupFont = rChr.Font.Duplicate
rChr.Font.Reset
rChr.Font = dupFont
End If 'rChr
Next rChr
End If 'rWrd.InRange
End If 'rWrd
Next rWrd
End If 'myRange rPrg
Next 'aField
End If 'rPrg
Next rPrg

End Sub

 

[David Turner]

Hm. Think it should be more like this. But it still doesn't work. The field
gets out of step with the paragraph.
I'm stuck!

Sub JumpHyperlinks()

Dim rPrg As Paragraph ' a paragraph
Dim rWrd As Range ' a word
Dim rChr As Range ' a character
Dim dupFont As Font ' font duplicate in range

Dim aField As Field
Dim fldRange As Range

For Each rPrg In ActiveDocument.Paragraphs
If rPrg.Range.Hyperlinks.Count = 0 Then
Set dupFont = rPrg.Range.Font.Duplicate
rPrg.Range.Font.Reset
rPrg.Range.Font = dupFont
ElseIf rPrg.Range.Hyperlinks.Count > 0 Then
For Each aField In rPrg.Range.Fields
Set fldRange = aField.Result
If rPrg.Range <> fldRange Then
For Each rWrd In rPrg.Range.Words
If rWrd.Hyperlinks.Count = 0 Then
Set dupFont = rWrd.Font.Duplicate
rWrd.Font.Reset
rWrd.Font = dupFont
ElseIf rWrd.Hyperlinks.Count > 0 Then
If rWrd <> fldRange Then
For Each rChr In rWrd.Characters
If rChr.Hyperlinks.Count = 0 Then
Set dupFont = rChr.Font.Duplicate
rChr.Font.Reset
rChr.Font = dupFont
End If 'rChr.Hyperlinks
Next rChr
End If 'rWrd <> fldRange
End If 'rWrd.Hyperlinks
Next rWrd
End If 'rPrg.Range
Next aField
End If 'rPrg.Range
Next rPrg

End Sub

 

[David Turner]

I was complicating my life. This simple code seems to work, if it's of
interest to anyone.

Sub HyperLinkSkip()

'Macro to jump over hyperlinks when resetting font

Dim rPrg As Paragraph
Dim rWrd As Range
Dim rChr As Range

For Each rPrg In ActiveDocument.Paragraphs
If rPrg.Range.Hyperlinks.Count = 0 Then
Set dupFont = rPrg.Range.Font.Duplicate
rPrg.Range.Font.Reset
rPrg.Range.Font = dupFont
ElseIf rPrg.Range.Hyperlinks.Count <> 0 Then
For Each rWrd In rPrg.Range.Words
If rWrd.Hyperlinks.Count = 0 Then
Set dupFont = rWrd.Font.Duplicate
rWrd.Font.Reset
rWrd.Font = dupFont
ElseIf rWrd.Hyperlinks.Count <> 0 Then
For Each rChr In rWrd.Characters
If rChr.Hyperlinks.Count = 0 Then
Set dupFont = rChr.Font.Duplicate
rChr.Font.Reset
rChr.Font = dupFont
ElseIf rChr.Hyperlinks.Count <> 0 Then
End If 'rChr
Next rChr
End If 'rWrd
Next rWrd
End If 'rPrg
Next rPrg

End Sub