Генератор электронной почты VBA - отправить уведомление сотруднику с просроченными билетами

ProgramBox

Генератор электронной почты VBA — отправить уведомление сотруднику с просроченными билетами

Post author:admin
Запись опубликована:10 декабря, 2022
Post category:Вопросы по программированию

#vba #ms-access #outlook #ms-access-2010

Вопрос:

Генератор электронной почты VBA — отправить уведомление сотруднику с просроченными билетами

Попытка сгенерировать электронные письма, чтобы уведомить пользователя о том, что его билет просрочен. Программа запускается и генерирует электронное письмо, однако, если у сотрудника просрочено несколько билетов, он отправляет им несколько электронных писем, а не одно со всеми просроченными элементами.

Ваша помощь действительно ценится!!!!

 Option Compare Database
Option Explicit

Public Sub SendSerialEmail()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean

'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"

lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" amp; Join(aHead, "</th><th>") amp; "</th></tr>"


On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If


Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")

 Do Until rec.EOF
        lCnt = lCnt   1
        ReDim Preserve aBody(1 To lCnt)
        aRow(1) = rec("ID")
        aRow(2) = rec("title")
        aRow(3) = rec("name")
        aRow(4) = rec("created")
        aRow(5) = rec("workdaysopen")
        aRow(6) = rec("full_name")
        aBody(lCnt) = "<tr><td>" amp; Join(aRow, "</td><td>") amp; "</td></tr>"
        rec.MoveNext
    Loop

aBody(lCnt) = aBody(lCnt) amp; "</table></body></html>"
If outStarted Then
outApp.Quit
End If

Do Until rs.EOF

emailTo = rs.Fields("email").Value
nameemployee = rs.Fields("full_name")

emailSubject = "Termination Tickets Overdue" amp; " - " amp; Date

emailText = Trim("Hi " amp; rs.Fields("full_name").Value) amp; ","

Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail@gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<BODY style=font-size:11pt;font-family:Segoe UI>" amp; "Hi " amp; nameemployee amp; "," amp; _
 "<br>" amp; "<br>" amp; _
"<BODY style=font-size:14pt;font-family:Segoe UI>" amp; "<b><span style=""color:#B22222"">Overdue Termination Tickets</b>" amp; _
Join(aBody, vbNewLine) amp; _
 "<br>" amp; _
"<BODY style=font-size:11pt;font-family:Segoe UI>" amp; "<b><i><span style=""color:#000000"">**Please note that tickets are overdue.</i></b>"
outMail.Display

rs.MoveNext
Loop

rs.Close
Set rs = Nothing
Set db = Nothing

If outStarted Then
outApp.Quit
End If

Set outMail = Nothing
Set outApp = Nothing

End Sub

1. Это потребует некоторой работы, но сначала, похоже, вы создаете два разных, но идентичных набора записей. В этом нет необходимости. вы можете один раз просмотреть набор записей, затем использовать rs.movefirst и снова просмотреть его. Я вижу, что второй делает… Цикл фактически создает электронное письмо для каждой записи в наборе записей. Рассмотрите возможность объединения данных в поле электронной почты в вашем запросе, а затем используйте агрегированный запрос для отправки электронной почты

2. Я вижу, что вы также используете номера билетов, поэтому, возможно, агрегированный запрос сам по себе не поможет вам пройти весь путь. В вашем VBA вы можете сделать несколько вещей, но, возможно, лучший способ — использовать рекурсивную функцию и объект коллекции (или два или три) для объединения всей информации для каждого получателя электронной почты. Я думаю, что ваш «ответ» был бы слишком большим для одного вопроса на форуме

Ответ №1:

Я приглашу вас протестировать следующий код, я провел тест этого кода.

Идея состоит в том, чтобы проверить, использовался ли уже адрес электронной почты, чтобы отправить одно электронное письмо на пользователя.

Отправить все квитанции всем пользователям по 1-одному электронному письму на пользователя

 Public Function IsEmailInArray(strEmail As String, arr() As String, lUbound As Long) As Boolean
  Dim i
  For i = 1 To lUbound
    If arr(i) = strEmail Then
      IsEmailInArray = True
      Exit Function
    End If
  Next
  IsEmailInArray = False
End Function

Public Sub so66016960SendSerialEmail()

Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean

Dim strTable As String

'Create the header row
  aHead(1) = "Ticket#"
  aHead(2) = "Summary"
  aHead(3) = "Ticket Status"
  aHead(4) = "Date Created"
  aHead(5) = "# Business Days Open"
  aHead(6) = "Assigned To"

  lCnt = 1
  ReDim aBody(1 To lCnt)
  aBody(lCnt) = "<table border='2'><tr><th>" amp; Join(aHead, "</th><th>") amp; "</th></tr>"


  On Error Resume Next
  Set outApp = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If outApp Is Nothing Then
    Set outApp = CreateObject("Outlook.Application")
    outStarted = True
  End If


  Set db = CurrentDb
  Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")

'
' get listing table of all overdue tickets:
'
  Do Until rs.EOF
    lCnt = lCnt   1
    ReDim Preserve aBody(1 To lCnt)
    aRow(1) = rs("ID")
    aRow(2) = rs("title")
    aRow(3) = rs("name")
    aRow(4) = rs("created")
    aRow(5) = rs("workdaysopen")
    aRow(6) = rs("full_name")
    aBody(lCnt) = "<tr><td>" amp; Join(aRow, "</td><td>") amp; "</td></tr>"
    rs.MoveNext
  Loop

  aBody(lCnt) = aBody(lCnt) amp; "</table>"
  '
  strTable = Join(aBody, vbNewLine)

  '
  'If outStarted Then
  '  outApp.Quit
  'End If
  '
'
' rewind:
'
  rs.MoveFirst
'
' now we reuse aBody() array as temporay array to used email addresses:
'
  lCnt = 0
'
  Do Until rs.EOF

    emailTo = rs.Fields("email").Value

    '
    ' if email is not yet used:
    '
    If (Not IsEmailInArray(emailTo, aBody, lCnt)) Then
    
      nameemployee = rs.Fields("full_name")

      emailSubject = "Termination Tickets Overdue" amp; " - " amp; Date

      emailText = Trim("Hi " amp; rs.Fields("full_name").Value) amp; ","

      Set outMail = outApp.CreateItem(olMailItem)
      outMail.To = emailTo
      outMail.CC = "myemail@gmail.com"
      outMail.Subject = emailSubject
    
      outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" amp; _
        "Hi " amp; nameemployee amp; "," amp; _
        "<br>" amp; "<br>" amp; _
        "<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" amp; _
        strTable amp; _
        "<br>" amp; _
        "<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" amp; _
        "</body></html>"
     
      outMail.Display

      '
      ' memory the email address just sent:
      '
      lCnt = lCnt   1
      aBody(lCnt) = emailTo

    End If
    
    rs.MoveNext
  
  Loop

  rs.Close
  Set rs = Nothing
  Set db = Nothing

  If outStarted Then
    outApp.Quit
  End If

  Set outMail = Nothing
  Set outApp = Nothing
End Sub

Чтобы отправить электронное письмо только с ее / его собственной информацией, мы ДЕЛАЕМ ЗАКАЗ ПО электронной почте, например:

 Public Function send1Mail(ByVal outApp, ByVal strEmail2Use, ByVal nameemployee, ByVal emailSubject, ByVal emailText, ByVal strTable)
  Dim outMail As Outlook.MailItem
  
  Set outMail = outApp.CreateItem(olMailItem)
  outMail.To = strEmail2Use
  outMail.CC = "myemail@gmail.com"
  outMail.Subject = emailSubject
    
  outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" amp; _
    "Hi " amp; nameemployee amp; "," amp; _
    "<br>" amp; "<br>" amp; _
    "<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" amp; _
    strTable amp; _
    "<br>" amp; _
    "<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" amp; _
    "</body></html>"
     
  outMail.Display

  Set outMail = Nothing

  send1Mail = 1

End Function

Public Sub SendSerialEmail2Each()

Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
'Dim strQry As String
'Dim aHead(1 To 6) As String
'Dim aRow(1 To 6) As String
'Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
'Dim outMail As Outlook.MailItem
Dim outStarted As Boolean

'
' nRows: number of rows in the table
' strTable: html table
' strTableHeader: html table header
' strEmail2Use: email address to send message
'
Dim nRows As Long
Dim strTable As String, strTableHeader As String, strEmail2Use As String

'Create the header row
' aHead(1) = "Ticket#"
' aHead(2) = "Summary"
' aHead(3) = "Ticket Status"
' aHead(4) = "Date Created"
' aHead(5) = "# Business Days Open"
' aHead(6) = "Assigned To"

' lCnt = 1
' ReDim aBody(1 To lCnt)
' strTableHeader = "<table border='2'><tr><th>" amp; Join(aHead, "</th><th>") amp; "</th></tr>"
'
  strTableHeader = "<table border='2'>" amp; _
    "<tr>" amp; _
    "<th>Ticket#</th>" amp; _
    "<th>Title</th>" amp; _
    "<th>Name</th>" amp; _
    "<th>Date Create</th>" amp; _
    "<th># Business Days Open</th>" amp; _
    "<th>Assigned To</th>" amp; _
    "</tr>"


  On Error Resume Next
  Set outApp = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If outApp Is Nothing Then
    Set outApp = CreateObject("Outlook.Application")
    outStarted = True
  End If


  Set db = CurrentDb
'
' ORDRER BY email is important here:
'
  Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets ORDER BY email;")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
  nRows = rs.RecordCount
'
' initialize:
'
  lCnt = 0
  strEmail2Use = ""
  strTable = ""
'
  Do Until rs.EOF
    
    lCnt = lCnt   1
    
    '
    ' get email of the current record:
    '
    emailTo = rs.Fields("email").Value
    
    '
    ' if first record: save email address and name.
    '
    If (lCnt = 1) Then
      strEmail2Use = emailTo
      nameemployee = rs.Fields("full_name")
      emailSubject = "Termination Tickets Overdue" amp; " - " amp; Date
      emailText = Trim("Hi " amp; rs.Fields("full_name").Value) amp; ","
    '
    ' send the email if address changes:
    '
    ElseIf (strEmail2Use <> emailTo) Then
      '
      ' close the html table:
      '
      strTable = strTableHeader amp; strTable amp; "</table>"

      '
      ' send 1 single mail:
      '
      send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable

      strEmail2Use = emailTo
      nameemployee = rs.Fields("full_name")
      emailSubject = "Termination Tickets Overdue" amp; " - " amp; Date
      emailText = Trim("Hi " amp; rs.Fields("full_name").Value) amp; ","
      
      strTable = ""
    End If

    '
    ' aggregate all records per user for tr's:
    '
    strTable = strTable amp; _
      "<tr>" amp; _
      "<td>" amp; rs("ID") amp; "</td>" amp; _
      "<td>" amp; rs("title") amp; "</td>" amp; _
      "<td>" amp; rs("name") amp; "</td>" amp; _
      "<td>" amp; rs("created") amp; "</td>" amp; _
      "<td>" amp; rs("workdaysopen") amp; "</td>" amp; _
      "<td>" amp; rs("full_name") amp; "</td>" amp; _
      "</tr>"
    
    
    '
    ' also send email at the last row of recordset:
    '
    If (lCnt = nRows) Then
      
      '
      ' close the html table:
      '
      strTable = strTableHeader amp; strTable amp; "</table>"

      '
      ' send 1 single mail:
      '
      send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
      '
    End If
        
    
    '
    ' move next:
    '
    rs.MoveNext

  Loop

'
' do this to save RAM:
'
  rs.Close
  Set rs = Nothing
  Set db = Nothing

  If outStarted Then
    outApp.Quit
  End If

  Set outApp = Nothing
End Sub

Скриншот проверенных данных:

Создание следующих окон электронной почты Outlook для щелчка и отправки.

1. Спасибо, мой друг!!! Работает отлично. Однако есть ли способ отфильтровать записи и отправить пользователю только его / ее записи.

2. Я попробовал приведенный выше код, и по какой-то причине он отправляет только 1 запись. Например, если у меня просрочено 5 записей, а у Марии — 2, я бы хотел, чтобы программа отправила мне электронное письмо с моими просроченными 5 записями и отправила Марии ее просроченные 2 записи. Я ДЕЙСТВИТЕЛЬНО ценю вашу помощь в этом!! Ты потрясающий!!

3. Извините, я исправил некоторые ошибки во втором коде.