Find and replace text in an email

[wmr]

Hello,

I want to personalize emails to my customers.

In the body of an email I want to replace the text Dear Sir, in Dear John. This is the code I already have. I am using Excel as mailinglist.

I use a template called: Test.oft. The first line of that text is: Dear Sirs

CustomerName = "Dear John"

Dim OutMail As Outlook.MailItem
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Set OutMail = OutApp.CreateItemFromTemplate("C:\AppData\Roaming\Microsoft\Templates\Test.oft")

     With OutMail
         .To = EmailAddress
         .Attachments.Add "xyz.pdf"
         .Send
    End With

Is possible what I want?

Kind regards
Willem

[gmayor]

What you propose sounds like mail merge. You can do all that you have mentioned using http://www.gmayor.com/ManyToOne.htm in one to one mode.

To create individual messages, using a macro to load your Outlook template and change 'Sirs' to say 'John' you must first decide where 'John' comes from. The substitution is the easy part of the exercise.

You must also decide whether the code is to be run from Outlook or Excel. Your code suggests Excel, but the forum is Outlook. If you want to do it from Outlook, you don't need to create an Outlook application as you are already in one., so you would use the following (I have changed some paths for testing, you must insert the correct paths).

Sub CreateAMessage()
Const CustomerName As String = "Dear John"
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim OutMail As Outlook.MailItem

    Set OutMail = CreateItemFromTemplate("C:\Path\Test.oft")

    With OutMail
        .To = "someone@somewhere.com"
        .Attachments.Add "c:\path\xyz.pdf"
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="Dear Sirs")
                oRng.Text = CustomerName
                Exit Do
            Loop
        End With
        .Display
        '.sEnd 'restore after testing
    End With
lbl_Exit:
    Set olInsp = Nothing
    Set OutMail = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

If you are running from Excel, which would seem more logical then the code would be:

Sub CreateAMessage()
Const CustomerName As String = "Dear John"
Dim oOutlookApp As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim OutMail As Object

    On Error Resume Next
    'Get Outlook if it's running
    Set oOutlookApp = GetObject(, "Outlook.Application")

    'Outlook wasn't running, start it from code
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If

    Set OutMail = oOutlookApp.CreateItemFromTemplate("C:\Path\Test.oft")

    With OutMail
        .To = "someone@somewhere.com"
        .Attachments.Add "c:\path\xyz.pdf"
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="Dear Sirs")
                oRng.Text = CustomerName
                Exit Do
            Loop
        End With
        .Display
        '.sEnd 'restore after testing
    End With
lbl_Exit:
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set OutMail = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[wmr]

Thank you, Gmayor, you code is working excellent!

Kind regards,
Willem

[wmr]

Graham helpt me out with this problem, but...

If I want to replace another field.

    With OutMail 
        .To = "someone@somewhere.com" 
        .Attachments.Add "c:\path\xyz.pdf" 
        Set olInsp = .GetInspector 
        Set wdDoc = olInsp.WordEditor 
        Set oRng = wdDoc.Range 
        With oRng.Find 
            Do While .Execute(FindText:="Dear Sirs") 
                oRng.Text = CustomerName 
                Exit Do 
            Loop 
        End With 

        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = Nothing
        Set oRng = wdDoc.Range
        With oRng.Find
            Do While .Execute(FindText:="CompanyName")
                oRng.Text = Actiecode
                Exit Do
            Loop
        End With

        .Send
         '.sEnd 'restore after testing
    End With

When I run this, the macro doesn't replace the second string.
But if I run this macro using F8 to step through it, it does replace the second string.

It seems that the macro runs to quickly.

Does someone recognize this problem (and have a solution)?

kind regards,
Willem

[gmayor]

I assume you have declared what 'Actiecode' refers to? You have removed the command to display the message and you have some duplicated statements. Try

With outMail
    .to = "someone@somewhere.com"
    .Attachments.Add "c:\path\xyz.pdf"
    Set olInsp = .GetInspector
    Set wdDoc = olInsp.WordEditor
    Set oRng = wdDoc.Range
    With oRng.Find
        Do While .Execute(FindText:="Dear Sirs")
            oRng.Text = CustomerName
            Exit Do
        Loop
    End With
    Set oRng = wdDoc.Range
    With oRng.Find
        Do While .Execute(FindText:="CompanyName")
            oRng.Text = Actiecode
            Exit Do
        Loop
    End With
    .Display 'Required
    '.Send 'restore after testing
End With

[wmr]

Hi Graham,

I declared Actiecode and CustomerName. But it still doesn't work.

I made a loop for 5 emails. When I displayed them all and checked them, the codes are properly replaced.
But, when I replace .Display by .Send, it doesn't replace the codes.

An I don't understand why.

Kind regards,
Willem

[gmayor]

.Display is required! My last update stressed it with a note in the code. If you remove it it won't work. You can enable .Send when you are sure that the code works, but you must retain .Display