Solved: Emailing From Excel Using an Outlook Template

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]

Hi Opv

Might find what you are looking for here, worth a look

http://www.rondebruin.nl/

Rob

Thanks. I've browsed through that site, and even tried one or two of his scripts; however, I didn't find anything that created the type of EXCEL/Outlook mail merge ostensibly achieved in the sample code posted in my original post. If I could get it to work in Excel 2000 and Outlook 2000, I think it would be more appealing to me.

Opv

I tinkered around with the Function aspect of the puzzle and, by chance, seem to have got it working in Outlook 2000. At least it works in plain text. I haven't yet figured out how to test it with HTML format. At any rate, here is the function. Feel free to tell me how this could be more streamlined.

[VBA]
'FUNCTION TO GET OUTLOOK DRAFT EMAIL TEMPLATE
Public Function getTemplate() As String

Dim OutApp, myFolder, myDraft As Object
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")
Set myFolder = OutApp.GetNamespace("MAPI")
Set myDrafts = myFolder.GetDefaultFolder(16)

For i = 1 To myDrafts.Items.Count
If myDrafts.Items(i).subject = "Template" Then
getTemplate = myDrafts.Items(i).body
End If
Next

End Function
[/VBA]

I'm still trying to get the associated Sub figured out as to how it should be modified to work in Outlook 2000, with the objective being that the Template used from Outlook would be in Rich Text Format. Any help would be appreciated, as it relates to the Sub and the Function.

Thanks,

Opv

Well, I fumbled around and successfully combined two different sets of code to achieve most of what I am attempting to do, which is generate email from Excel which uses an existing template in the DRAFT folder within Outlook, and then personalizes the emails to each person on the recipient list.

The script below seems to work fine with the earlier Function I posted earlier. The combined Function and Subroutine seem to work as designed but each email is sent in plain text rather than retaining the HTML format of the original draft template. Is there any way the Function and/or Subroutine could be modified to capture and retain the HTML formatting?

[vba]
Sub TestFile()
Dim OutApp, OutMail As Object
Dim cell As Range
Dim myBody As String

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

Sheets("Sheet2").Activate

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.row, "C").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.subject = "LHS Joint-Class Reunion"
myBody = getTemplate()
myBody = Replace(myBody, "{name}", cell.Offset(0, -1))
'body = Replace(myBody, "{number}", cell.Offset(0,?)
.body = myBody

'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

[/vba]

I think I figured it out. The following code seems to do what I'm wanting it to do.

[vba]
'FUNCTION TO GET OUTLOOK DRAFT EMAIL TEMPLATE
Public Function getTemplate() As String

Dim OutApp, myFolder, myDrafts As Object
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")
Set myFolder = OutApp.GetNamespace("MAPI")
Set myDrafts = myFolder.GetDefaultFolder(16) 'DRAFT Folder

For i = 1 To myDrafts.Items.Count
If myDrafts.Items(i).subject = "Template" Then
getTemplate = myDrafts.Items(i).HTMLbody
End If
Next

End Function

[/vba]

[vba]
Sub TestFile()
Dim OutApp, OutMail As Object
Dim cell As Range
Dim myBody As String

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

Sheets("Sheet2").Activate

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.row, "C").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.subject = "LHS Joint-Class Reunion"
myBody = getTemplate()
myBody = Replace(myBody, "{name}", cell.Offset(0, -1))
'body = Replace(myBody, "{number}", cell.Offset(0,?)
.HTMLbody = myBody

'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

[/vba]

My script is working fine. However, I am curious about something. When I've noticed that when I run the script (obviously from Excel) there are no Outlook active inspector windows opened, regardless of the number of recipients. The email is sent silently, so to speak.

However, when I run a similar routine from within Outlook, a new inspector window is opened for each recipient, which can get ugly when there are more than a few recipients.

Is application.screenupdating preventing the Outlook inspector windows when the Excel script is running or is something else responsible for that behavior? I don't think application.screenupdating will work with VBA code created in Outlook. Not sure, but I'd love to mimic the Excel behavior within Outlook.

I may have resolved my previous question by using item.copy.send rather than just item.send.