通过 CDO 向多个收件人发送包含其记录的电子邮件答案

【问题标题】：Send E-mail to multiple recipients containing thier records via CDO通过 CDO 向多个收件人发送包含其记录的电子邮件
【发布时间】：2021-10-22 03:51:59
【问题描述】：

我有一个代码当前发送 HTML 格式的消息，该消息从数据库中查询记录，然后发送给特定的人群。

但我想将代码功能扩展到从数据库中的表中查找收件人，并发送包含特定收件人记录的 HTML 格式信息。
代码

Public Function sendmail()

    Dim db As DAO.Database
    Dim rec As DAO.Recordset
    Dim strQry, strTo As String
    Dim aHead(1 To 11) As String
    Dim aRow(1 To 11) As String
    Dim aBody(), aBody2 As String
    Dim lCnt As Long
    Dim getdate As String
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant


    aHead(1) = "RecordID"
    aHead(2) = "Name"
    aHead(3) = "Gender"
    aHead(4) = "Transaction Code"
    aHead(5) = "Mobile"

    lCnt = 1
    ReDim aBody(1 To lCnt)
    aBody(lCnt) = "<HTML><body><br>Dear All,</br> <br>Good Day.</br> <br>Please refer below for the details of your current system records & " & _
    "Kindly assist to check and confirm. </br>  " & _
    "<br><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"

    strQry = "SELECT * FROM tblrecon "
    Set db = CurrentDb
    Set rec = CurrentDb.OpenRecordset(strQry)
    If rec.RecordCount <> 0 Then

    If Not (rec.EOF) Then
        Do While Not rec.EOF
            strTo = rec.Fields("Email")
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            aRow(1) = rec("RecordID")
            aRow(2) = rec("Name")
            aRow(3) = rec("Gender")
            aRow(4) = rec("TransactionCode")
            aRow(5) = rec("Mobile")
            aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
            rec.MoveNext
        Loop
    End If

        aBody(lCnt) = aBody(lCnt) & "</table></body></html> <br> Sincerly, </br> <br> System Operator </br>"

        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")
        iConf.Load -1
        Set Flds = iConf.Fields
        With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "MySMTPServer"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "Myport"
        .Update
        End With

            With iMsg
            Set .Configuration = iConf
            Do While rec.EOF And (rec.Fields("Email") = strTo)
            .HTMLBody = Join(aBody, vbNewLine)
            rec.MoveNext
            Loop

            .To = strTo
            .BCC = ""
            .From = "Test@TestMail.com"
            .Subject = "Record Summary"
            .send
            End With
        Set iMsg = Nothing
        Set iConf = Nothing
        Set Flds = Nothing

        Else
    Exit Function
End If
End Function

【问题讨论】：

您的问题是什么？问题是什么 - 错误消息、错误结果、没有任何反应？
嗨@June7，我想将记录摘要发送给它的所有者，目前这个代码发送的是表中所有电子邮件地址的所有记录。

标签： ms-access cdo.message

【解决方案1】：

如果您希望向每个收件人发送单独的电子邮件，并且仅包含与每封电子邮件相关的记录，则在电子邮件地址循环中构建电子邮件记录正文。这意味着打开一个电子邮件地址记录集，然后在该循环中打开一个相关数据记录的记录集并循环遍历该记录集。

Public Function sendmail()

    Dim db As DAO.Database
    Dim rec As DAO.Recordset
    Dim mail As DAO.Recordset

    Dim aHead(1 To 11) As String
    Dim aRow(1 To 11) As String
    Dim aBody(), aBody2 As String
    Dim lCnt As Long
    Dim getdate As String
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant

    aHead(1) = "RecordID"
    aHead(2) = "Name"
    aHead(3) = "Gender"
    aHead(4) = "Transaction Code"
    aHead(5) = "Mobile"

    Set db = CurrentDb
    Set mail = db.OpenRecordset("SELECT DISTINCT Email FROM tblrecon")

    While Not mail.EOF
        lCnt = 1
        ReDim aBody(1 To lCnt)
        aBody(lCnt) = "<HTML><body><br>Dear All,</br> <br>Good Day.</br> <br>Please refer below for the details of your current system records & " & _
        "Kindly assist to check and confirm. </br>  " & _
        "<br><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
        Set rec = db.OpenRecordset("SELECT * FROM tblrecon WHERE Email='" & mail!Email & "'")
        If Not rec.EOF Then
            Do While Not rec.EOF
                lCnt = lCnt + 1
                ReDim Preserve aBody(1 To lCnt)
                aRow(1) = rec("RecordID")
                aRow(2) = rec("Name")
                aRow(3) = rec("Gender")
                aRow(4) = rec("TransactionCode")
                aRow(5) = rec("Mobile")
                aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
                rec.MoveNext
            Loop
            rec.Close
        End If

        aBody(lCnt) = aBody(lCnt) & "</table></body></html> <br> Sincerly, </br> <br> System Operator </br>"

        Set iMsg = CreateObject("CDO.Message")
        Set iConf = CreateObject("CDO.Configuration")
        iConf.Load -1
        Set Flds = iConf.Fields
        With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "MySMTPServer"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "Myport"
        .Update
        End With

        With iMsg
        Set .Configuration = iConf
        .HTMLBody = Join(aBody, vbNewLine)
        .To = mail!Email
        .BCC = ""
        .From = "Test@TestMail.com"
        .Subject = "Record Summary"
        .Send
        End With
        mail.MoveNext
    Loop
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End

这可以通过 1 个有序记录集来完成，但这需要使用记录中的电子邮件地址设置一个变量，并检查记录集中该电子邮件何时更改以确定何时应发送电子邮件并为下一封电子邮件启动一组新记录。

【讨论】：

您好@June7，感谢您花时间帮助我。您的建议和修改代码对我有用。我只是在最后一个循环中添加 .movenext 以在发送所有记录后停止循环。谢谢你:)
糟糕，疏忽大意。固定答案。