Question

我对VBA编码还很陌生，在这里没有得到任何帮助。我设法创建了一些代码来使用查询发送电子邮件。但是，如果可能的话，我想通过单击一个命令按钮使用不同的查询来发送多封电子邮件。

Private Sub Command161_Click()

    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) = "ID"
    aHead(2) = "Title"
    aHead(3) = "Priority"
    aHead(4) = "Requested By"
    aHead(5) = "Type of task"
    aHead(6) = "Start Date"
    aHead(7) = "Due Date"

    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 [OutstandingTasks-John]"
    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("ID")
            aRow(2) = rec("Title")
            aRow(3) = rec("Priority")
            aRow(4) = rec("Requested By")
            aRow(5) = rec("Type of task")
            aRow(6) = rec("Start Date")
            aRow(7) = rec("Due Date")

            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 = "john.smith@johnsmith.com"
    olItem.Subject = "Outstanding Tasks"
    olItem.HTMLBody = Join(aBody, vbNewLine)
    olItem.Display
End Sub

从上面的代码中，将使用查询[OutstandingTasks-John]向John Smith发送一封电子邮件，其中列出了他的未完成任务。

但是，我想通过同一操作按钮使用查询[OutstandingTasks-Emily]单独向Emily Smith发送一封电子邮件，并附上她的未完成任务列表。

我可以复制并粘贴在原始代码下，并对其进行一些更改，但是我如何加入这两套代码？

也很高兴。当我发送电子邮件给约翰·史密斯。它出现在Outlook中，我必须手动发送。如何从操作按钮自动发送此消息？

Answer 1

是的，您可以复制粘贴代码。您只需要更新应包含Emily而不是John的部分即可。

现在，继续前进，如果John和Emily成为John，Emily，Carla和Steve，您应该考虑合并Johns任务表和Emily的任务表，以便为所有任务提供一个共享表，然后放置 name和电子邮件，您将在选择查询中发送电子邮件至，然后我们可以循环那个记录集，而不是复制粘贴相同的代码块。

要使用以下方法发送和发送电子邮件，只需添加olItem.Send

此外，最好确保您出于某种原因使事物变暗，并在完成操作后使用set [object] = Nothing进行清理。

立即修复

Private Sub Command161_Click()

    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) = "ID"
    aHead(2) = "Title"
    aHead(3) = "Priority"
    aHead(4) = "Requested By"
    aHead(5) = "Type of task"
    aHead(6) = "Start Date"
    aHead(7) = "Due Date"

    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 [OutstandingTasks-John]"
    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("ID")
            aRow(2) = rec("Title")
            aRow(3) = rec("Priority")
            aRow(4) = rec("Requested By")
            aRow(5) = rec("Type of task")
            aRow(6) = rec("Start Date")
            aRow(7) = rec("Due Date")

            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 = "john.smith@johnsmith.com"
    olItem.Subject = "Outstanding Tasks"
    olItem.HTMLBody = Join(aBody, vbNewLine)
    olItem.Display
    olItem.Send



    'EMILY code block

    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 [OutstandingTasks-Emily]"
    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("ID")
            aRow(2) = rec("Title")
            aRow(3) = rec("Priority")
            aRow(4) = rec("Requested By")
            aRow(5) = rec("Type of task")
            aRow(6) = rec("Start Date")
            aRow(7) = rec("Due Date")

            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 = "emily.smith@emilysmith.com"
    olItem.Subject = "Outstanding Tasks"
    olItem.HTMLBody = Join(aBody, vbNewLine)
    olItem.Display
    olItem.Send

    Set olApp = Nothing
    Set olItem = Nothing
    Set rec = Nothing
    set db = Nothing

End Sub

未来考虑因素

Private Sub Command161_Click()

    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


    Dim personRS as DAO.Recordset

    Set db = CurrentDb
    Set personRS = db.OpenRecordset("SELECT DISTINCT PERSON, PERSON_EMAIL FROM [CombinedTaskList])

    If Not (personRS.BOF and personRS.EOF) Then

        'Create the header row
        aHead(1) = "ID"
        aHead(2) = "Title"
        aHead(3) = "Priority"
        aHead(4) = "Requested By"
        aHead(5) = "Type of task"
        aHead(6) = "Start Date"
        aHead(7) = "Due Date"


        Do While Not personRS.EOF
            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 [CombinedTaskList] WHERE PERSON = " & personRS("PERSON")
            Set rec = db.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("ID")
                    aRow(2) = rec("Title")
                    aRow(3) = rec("Priority")
                    aRow(4) = rec("Requested By")
                    aRow(5) = rec("Type of task")
                    aRow(6) = rec("Start Date")
                    aRow(7) = rec("Due Date")

                    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 = personRS("PERSON_EMAIL")
            olItem.Subject = "Outstanding Tasks"
            olItem.HTMLBody = Join(aBody, vbNewLine)
            olItem.Send

            Set olApp = Nothing
            Set olItem = Nothing

            personRS.MoveNext

        Loop

    End If

    Set personRS = Nothing
    Set rec = Nothing
    Set db = Nothing

End Sub

使用一个命令按钮从多个查询发送多封电子邮件

1 个答案: