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