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

Question

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

但我想将代码功能扩展为从数据库中的 table 查找收件人，并发送包含特定收件人记录的 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

Answer 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 个有序记录集来完成，但这需要使用记录中的电子邮件地址设置一个变量，并检查电子邮件何时在记录集中更改，以确定何时发送电子邮件并为下一封电子邮件启动一组新记录.

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

Send E-mail to multiple recipients containing thier records via CDO

ms-access

cdo.message