I have been experimenting with various methods of generating Outlook emails from Excel. I've tried everything from generating a Distribution List, opening Outlook and placing the list of recipients in the TO: or BCC: fields, to scripts that export the distribution list to a TXT of CSV file.

I recently came across a web page that describes a very interesting procedure which basically performs a mail merge using contacts maintained in Excel and merging with an existing DRAFT email in Outlook with "Template" in the subject line.

The procedure is described in more detail at http://techtravelthink.blogspot.com/...excel-and.html.

Unfortunately, the procedure is designed to work with Outlook 2010. Is there any way this could be redesigned to work on Outlook 2000?

[vba]
Private Function GetRichTextTemplate() As String

Dim OLF As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem

Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderDrafts )
Set oItems = OLF.Items

For Each Mailobject In oItems
If Mailobject.subject = "Template" Then
GetRichTextTemplate = Mailobject.HTMLBody
Exit Function
End If
Next

End Function

[/vba]


[vba]



Public Sub SendMailMergeEmail()
Dim OLF As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim olContact As Outlook.Recipient
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderIn box)

Dim subject As String
subject = "<adv> Latest Product Update"

Dim body As String
Dim template As String
template = GetRichTextTemplate()

Dim cnumber As String
Dim cname As String
Dim email As String

Dim row As Integer
row = 2

cnumber = Sheets("Main").Range("A" & row)
cname = Sheets("Main").Range("B" & row)
email = Sheets("Main").Range("C" & row)
While cnumber <> ""
Set olMailItem = OLF.Items.Add
With olMailItem
Set olContact = .Recipients.Add(email)
olContact.Resolve

.subject = subject
.BodyFormat = olFormatRichText

body = Replace(template, "{name}", cname)
body = Replace(body, "{number}", cnumber)
.HTMLBody = body

.Send
End With

row = row + 1
cnumber = Sheets("Main").Range("A" & row)
cname = Sheets("Main").Range("B" & row)
email = Sheets("Main").Range("C" & row)
Wend

Set olContact = Nothing
Set olMailItem = Nothing
Set OLF = Nothing
End Sub
</adv>

[/vba]