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