Find and Replace macro - special characters aren't being replaced

[AUS_LW]

Hi,
I'm hoping someone can help me with this one. I thought it was going to be a cake walk, but I just can't get it to work. We have recently trademarked a phrase. So when people send an email, I need it to append the trademark (R) character if not already done. I can add it no worries, but I can't seem to stop it adding if it is already there.
Here is what I have so far:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

On Error GoTo ExitPoint
Item.HTMLBody = Replace(Item.HTMLBody, "Phrase®", "Phrase")
Item.HTMLBody = Replace(Item.HTMLBody, "Phrase", "Phrase®")

ExitPoint:
End Sub

I did it this way incase someone pastes the word, it won't show up with two (R)s, but unfortunately, it doesn't seem to affect it.
I've also tried replacing the (R) with ? and ^? both inside and outside the "", but it doesn't work.

Does anyone know how to get around this?
Thank you for your assistance

[gmayor]

The following should work for you
Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Const strPhrase1 As String = "Phrase"
Const strPhrase2 As String = "Phrase®"
On Error GoTo ExitPoint
With Item
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:=strPhrase1 & "[!®]", MatchWildCards:=True)
oRng.Text = strPhrase2
oRng.collapse 0
Loop
End With
.Display
.Send
End With
ExitPoint:
Set olInsp = Nothing
Set Item = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub

[AUS_LW]

Hi GMayor,

Thank you for this, it works very well. The only thing I can't understand is when it adds the (R), it removes the next character. e.g. if I have Phrase. (with a period), it will replace it with Phrase(R) with no period, same with spaces and line breaks. Do you know how to fix this?

Thank you for your help so far


The following should work for you
Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Const strPhrase1 As String = "Phrase"
Const strPhrase2 As String = "Phrase®"
On Error GoTo ExitPoint
With Item
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:=strPhrase1 & "[!®]", MatchWildCards:=True)
oRng.Text = strPhrase2
oRng.collapse 0
Loop
End With
.Display
.Send
End With
ExitPoint:
Set olInsp = Nothing
Set Item = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub

[gmayor]

Oops! The following should fix that

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Const strPhrase1 As String = "Phrase([!®])"
Const strPhrase2 As String = "Phrase®\1"
On Error GoTo ExitPoint
With Item
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(FindText:=strPhrase1, _
ReplaceWith:=strPhrase2, _
MatchWildCards:=True)
oRng.collapse 0
Loop
End With
.Display
.Send
End With
ExitPoint:
Set olInsp = Nothing
Set Item = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub