访问VBA以表格格式将查询结果发送到Outlook电子邮件 [英] Access VBA To Send Query Results to Outlook Email in Table Format
问题描述
我想根据我的表格中的查询结果发送一封带有 Outlook 的电子邮件，但带有表格格式(在正文中).出于某种原因，该代码仅将表中的最后一条记录输出到电子邮件正文，而不是循环并添加所有 3 条记录.
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 = "test@email.com"
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
推荐答案
您在每个循环中都在更改 HTMLBody，而不是添加到其中.您应该在循环上方设置标题行，然后在循环内设置每一行.我喜欢填充数组并使用 Join 函数 - 它在视觉上对我来说更令人愉悦.
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 = "example@example.com"
olItem.Subject = "Test E-mail"
olItem.htmlbody = Join(aBody, vbNewLine)
olItem.display
End Sub
这篇关于访问VBA以表格格式将查询结果发送到Outlook电子邮件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
