Access VBA To Send Query Results to Outlook Email in Table Format
13,797
You're changing the HTMLBody every loop rather than adding to it. You should set your header row above the loop, then set each row inside the loop. I like to fill up arrays and use the Join function - it's more visually pleasing to me.
Public Sub NewEmail()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 7) As String
Dim aRow(1 To 7) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Request Type"
aHead(2) = "ID"
aHead(3) = "Title"
aHead(4) = "Requestor Name"
aHead(5) = "Intended Audience"
aHead(6) = "Date of Request"
aHead(7) = "Date Needed"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From Email_Query"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Test1")
aRow(2) = rec("Test2")
aRow(3) = rec("Test3")
aRow(4) = rec("Test4")
aRow(5) = rec("Test5")
aRow(6) = rec("Test6")
aRow(7) = rec("Test7")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.display
olItem.To = "[email protected]"
olItem.Subject = "Test E-mail"
olItem.htmlbody = Join(aBody, vbNewLine)
olItem.display
End Sub
Author by
user3596788
Updated on June 05, 2022Comments
-
user3596788 almost 2 years
I would like to send an e-mail with outlook based on the query results from my table but with table formatting (in the body). For some reason the code is only outputting the last record in the table to the e-mail body, instead of looping and adding all 3 records.
Any suggestions, or a better way to code this?
Public Sub NewEmail() 'On Error GoTo Errorhandler Dim olApp As Object Dim olItem As Variant Dim olatt As String Dim olMailTem As Variant Dim strSendTo As String Dim strMsg As String Dim strTo As String Dim strcc As String Dim rst As DAO.Recordset Dim rs As DAO.Recordset Dim db As DAO.Database Dim qry As DAO.QueryDef Dim fld As Field Dim varItem As Variant Dim strtable As String Dim rec As DAO.Recordset Dim strqry As String strqry = "SELECT * From Email_Query" strSendTo = "[email protected]" strTo = "" strcc = "" Set olApp = CreateObject("Outlook.application") Set olItem = olApp.CreateItem(olMailTem) olItem.Display olItem.To = strTo olItem.CC = strcc olItem.Body = "" olItem.Subject = "Test E-mail" Set db = CurrentDb Set rec = CurrentDb.OpenRecordset(strqry) If Not (rec.BOF And rec.EOF) Then rec.MoveLast rec.MoveFirst intCount = rec.RecordCount For intLoop = 1 To intCount olItem.HTMLBody = "<HTML><body>" & _ "<table border='2'>" & _ "<tr>" & _ "<th> Request Type </th>" & _ "<th> ID </th>" & _ "<th> Title </th>" & _ "<th> Requestor Name </th>" & _ "<th> Intended Audience </th>" & _ "<th> Date of Request</th>" & _ "<th> Date Needed </th>" & _ "</tr>" & _ "<tr>" & _ "<td>" & rec("Test1") & "</td>" & _ "<td>" & rec("Test2") & "</td>" & _ "<td>" & rec("Test3") & "</td>" & _ "<td>" & rec("Test4") & "</td>" & _ "<td>" & rec("Test5") & "</td>" & _ "<td>" & rec("Test6") & "</td>" & _ "<td>" & rec("Test7") & "</td>" & _ "</tr>" & _ "<body><HTML>" rec.MoveNext Next intLoop End If MsgBox "E-mail Sent" Set olApp = Nothing Set olItem = Nothing Exit_Command21_Click: Exit Sub ErrorHandler: MsgBox Err.Description, , Err.Number Resume Exit_Command21_Click End Sub