Отправка нескольких писем из нескольких запросов с помощью одной кнопки - PullRequest
Новая
       18

Отправка нескольких писем из нескольких запросов с помощью одной кнопки

0 голосов
/ 10 мая 2019

Я довольно новичок в кодировании 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].

Однако, с помощью той же кнопки действия я хотел бы отправить Эмили Смит электронное письмо отдельно с ее списком невыполненных задач, используя запрос [OutstandingTasks-Emily].

Я могу просто скопировать и вставить под исходный код и слегка его изменить, но как мне объединить эти два набора кода?

Также приятно иметь.Когда я отправлю электронное письмо Джону Смиту.Это появляется в перспективе, и я должен вручную отправить его.Как я могу автоматически отправить это с кнопки действия?

1 Ответ

0 голосов
/ 14 мая 2019

Да, вы можете просто скопировать вставить код.Вам просто нужно обновить части, которые должны содержать Эмили вместо Джона.

Теперь, двигаясь вперед, если Джон и Эмили станут Джоном, Эмили, Карлой и Стивом, вам следует подумать о слиянии таблицы задач Джона и таблицы задач Эмили.таким образом, существует общая таблица для всех задач, а затем добавьте имя и адрес электронной почты , на который вы отправляете письмо, в запросе выбора, тогда мы можем просто зациклить этот набор записей вместо копиивставка одних и тех же блоков кода.

Для отправки и отправки по электронной почте, используя метод, описанный ниже, вам просто нужно добавить 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
...