I had a requirement to allow staff to use word to generate rich content emails based on a corporate template.
Then use the word doc to merge with our membership DB and send to outlook for mailing.
The core code for achieving this is as follows
Code:
Private Sub Send_Email_Click()
Dim sFile As String
Dim i As Integer
Dim itm As Object
Dim ID As String
Dim wd As Word.Application
Dim Doc As Word.Document
Dim objApp As Outlook.Application
Dim l_Msg As MailItem
Dim oReceipt As Outlook.Recipient
' check buletin selected for sending
If Nz(Me!sendEBS, "") = "" Then
MsgBox "Please select a bulletin to send"
Exit Sub
End If
'get email addresses record set
Select Case Me!sTo
Case Is = "Members"
Set rs = CurrentDb.OpenRecordset("SELECT [EmailName] FROM [Contacts] WHERE [Contact_Type] = 'Member'", dbOpenSnapshot, dbSeeChanges)
Case Is = "Prospects"
Set rs = CurrentDb.OpenRecordset("SELECT [EmailName] FROM [Contacts] WHERE [Contact_Type] = 'Prospect'", dbOpenSnapshot, dbSeeChanges)
Case Else
MsgBox "Please select a recipient"
Exit Sub
End Select
'Are You Sure
If vbNo = MsgBox("Send [ " & Me!sendEBS & " ] To [ " & Me!sTo & " ], Are you sure?", vbYesNo) Then
Exit Sub
End If
Msg = "Enter the subject to be used for each email message." ' Set prompt.
tit = " Email Subject Input" ' Set title.
' Display message, title
sSubject = InputBox(Msg, tit)
If Nz(sSubject, "") = "" Then
MsgBox "You must supply an email subject"
Set rs = Nothing
Exit Sub
End If
sFile = EBS_DIR & Me!sendEBS
[b]
Set wd = CreateObject("Word.Application")
Set Doc = wd.Documents.Open(FileName:=sFile, ReadOnly:=True)
Set itm = Doc.MailEnvelope.Item
With itm
.To = DEFAULT_EMAIL
.Subject = sSubject
.Save
ID = .EntryID
End With
'clear references
Doc.Close wdDoNotSaveChanges
wd.Quit False
Set itm = Nothing
Set Doc = Nothing
Set wd = Nothing
[/b]
' start email and get saved item
Set objApp = CreateObject("Outlook.Application")
Set l_Msg = objApp.GetNamespace("MAPI").GetItemFromID(ID)
With l_Msg
'Loop over recipients
Do While Not rs.EOF
Set oReceipt = .Recipients.Add(rs.Fields("EmailName"))
oReceipt.Type = olBCC
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
' add any attachments
If (Me.editEBS.ListCount > 0) Then
i = 0
Do While i < Me.attEBS.ListCount
.Attachments.Add (Me.attEBS.ItemData(i))
i = i + 1
Loop
End If
.Display
End With
'clear references
Set oReceipt = Nothing
Set l_Msg = Nothing
Set objApp = Nothing
End Sub
The key to this is using the MailEnvelope on the Word object [
which I have highlighted] to turn the document into an email message and save into drafts.
You can then use the MAPI namespace to get the saved draft email and manipulate further and display for sending.
I have created an MS Access 2003 application download so you can see how I put it all together.
I am unsure which versions of Office this works in as we only have MS-Office 2003.
You will need to download the zip file and place the EBS.doc on the C:\ drive, there is also a C:\EBS\ folder with a test file in you will need as well.
You will see when viewing the code there are a few 'constants' which you can play with to move the file locations.
Also I have included some dummy tables, but you can of course change this to connect to your SQL or other data source for use by the recordset in the code.
Hope you find this as useful a I have.
http://www.homeloanpartnership.com/Word-Mailer-2003.zip
NOTE: I have not supplied any error checking, you will need to handle your own errors ;-)
