Hello.
I have an Access 2010 database and a Word 2010 template which I use to send an email to a single student. I click a button on my form and the VBA code uses the fields on my form to open a Word template, merge the single student's information to a Word template by using bookmarks, opens Outlook, and sends the Word template as the body of the message. It gets the email address from the Access form. For a single student, I capture the data sent and other relevant information and store it in an Access table called student_email_history.
I would like to be able to send email to multiple students that are the result of an Access query. I would still need to merge each student's information with Word, use the Word document as the body of the Outlook email message, send the email, then capture the date sent and student name in the student_email_history table. I would have to move through all the records in the query, merging with Word, sending the email, and storing data as I go along.
Would anyone know how I could do this using VBA?
This is the gist of what I now have in the VBA code of the form in which I will launch the query to get multiple email addresses. The name of my Word template is Applicant Welcome Letter.dotx and the name of the SELECT query that pulls the student information is called BULK_EMAIL_STDNTS. I am omitting the part that appends new records to the STUDENT_EMAIL_HISTORY for now...............
Option Compare Database
Option Explicit
Private outlookApp As Outlook.Application
Private outlookNamespace As Outlook.NameSpace
Private Sub BulkInitOutlook()
'Initialize a session in Outlook
Set outlookApp = New Outlook.Application
'Return a reference to the MAPI layer
Set outlookNamespace = outlookApp.GetNamespace("MAPI")
'Let the user logon to Outlook with the
'Outlook Profile dialog box
'and then create a new session
outlookNamespace.Logon , , True, False
End Sub
Private Sub BulkCleanUp()
' Clean up public object references.
Set outlookNamespace = Nothing
Set outlookApp = Nothing
End Sub
Private Sub cmdSENDemail_Click()
Dim rs As Recordset
Dim vRecipientList As String
Dim vMsg As String
Dim vSubject As String
Dim MailItem As Outlook.MailItem
Dim strFrom As String
Dim emailto As String
Dim emlbodyfrmword As String
Dim AddyLineVar As String
Dim Salutation As String
Dim Wrd As New Word.Application
Dim MergeDoc As String
Dim RES As String
BulkInitOutlook
Set MailItem = outlookApp.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset("SELECT * FROM BULK_EMAIL_STDNTS")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do
If Not IsNull(rs!EMAIL) Then
MailItem.TO = rs![EMAIL]
MailItem.SUBJECT = rs![txtSUBJECT]
AddyLineVar = rs!FIRST_NAME & " " & rs!LAST_NAME & vbCrLf & rs!txtADDRESS1 & vbCrLf & Trim(rs!txtCity) & ", " & rs!txtState & " " & rs!txtZip
Salutation = rs!FIRST_NAME
'Declare an instance of Microsoft Word
Set Wrd = CreateObject("Word.Application")
'specify the path and name to the word document
MergeDoc = "C:\users\dbeville\desktop\Applicant Welcome Letter.dotx"
'open the document template, make it visible
Wrd.Documents.Add MergeDoc
Wrd.Visible = True
If (rs![RESIDENCY] = "IS") Then
RES = "In State"
Else
RES = "Out of State"
End If
'replace each bookmark with current data
With Wrd.ActiveDocument.Bookmarks
Rem .item("AddressLines").Range.Text = AddyLineVar
.item("firstname").Range.Text = rs!FIRST_NAME
.item("plandesc").Range.Text = rs!PlanDesc
.item("emplid").Range.Text = rs!EMPLID
.item("termdesc").Range.Text = rs!TERMDESC
.item("acadprog").Range.Text = rs!ACADPROG
.item("residency").Range.Text = RES
End With
MailItem.Body = Wrd.ActiveDocument.Content
'append email record to student email history table
MailItem.send
Set MailItem = Nothing
BulkCleanUp
rs.MoveNext
Else
rs.MoveNext
End If
Loop Until rs.EOF
End If
End Sub
At this point, nothing is happening after I've cleaned up a few errors.
Debbi
