Question

我想根据我的表中的查询结果发送一封带Outlook的电子邮件，但是有表格格式（在正文中）。由于某种原因，代码只将表中的最后一条记录输出到电子邮件正文，而不是循环并添加所有3条记录。

有任何建议或更好的方法来编码吗？

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

Answer 1

您每次循环都要更改HTMLBody，而不是添加它。您应该在循环上方设置标题行，然后在循环内设置每一行。我喜欢填充数组并使用Join函数 - 它在视觉上更令我愉悦。

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电子邮件发送查询结果

1 个答案: