审核邮件发送

Question

我有下面的电子邮件脚本。如何包含一个调用，以便为每条记录插入活动日期（发送日期邮件）以及字段[EmailAddress]，[Due Date]到审计表（tblauditlist）中？

Private Sub Command0_Click() 

    Dim olApp As Outlook.Application 
    Dim olNs As Outlook.NameSpace 
    Dim olMailItem As Outlook.MailItem 
    Dim rsEmails As DAO.Recordset 

    Const sBODY As String = "Test Email - Delete Me" 
    Const sSUBJ As String = "Mailing List Test" 
    Const sSQL As String = "SELECT [EmailAddress],[Due Date] &"" ""&[EvalFor] As Subjj FROM tblMailingList;" 

    Set olApp = Outlook.Application 
    Set olNs = olApp.GetNamespace("MAPI") 
    Set rsEmails = CurrentDb.OpenRecordset(sSQL) 

    'Create them, but don't send yet 
    Do Until rsEmails.EOF 
     Set olMailItem = olApp.CreateItem(0) 
     With olMailItem 
      .To = rsEmails.Fields("EmailAddress").Value 
      .Subject = rsEmails.Fields("Subjj").Value 
      .Body = sBODY 
      .Save 
     End With 
     rsEmails.MoveNext 

     olMailItem.Send 
    Loop 

End Sub 

Answer 1

如果可以合理地假设你的[tblAuditList]已经基于三个文本字段（[EML]，[错误]，[errdsc]）和日期时间默认为现在（），那么这些增加应该是足够。

Const sQRY String = "INSERT INTO tblAuditList ([eml],[errno],[errdsc]) VALUES ('×E×','×S×','×D×');" 'put this above with the others 

    'all of the regular code above this 
    olMailItem.Send 
    CurrentDb.Execute Replace(Replace(Replace(sQRY, "×E×", CStr(rsEmails.Fields("EmailAddress"))), _ 
                "×S×", Err.Number), _ 
                "×D×", IIf(Err.Number, Err.Description, "Success")), _ 
         dbFailOnError + dbSeeChanges 
Loop 

如果您更愿意保持Err.Number的是真实的数字，更改[tblAuditList]。[错误]是Number类型和删除引号包裹插入值。对于这样的日志，我总是喜欢让默认的Now（）填充日期时间字段，因为事件通常是实时写入的。

请注意，这些是Chr（215）'times'字符而不是常规小写字母x。

Answer 2

使用循环内的DAO数据库连接添加VBA追加查询：

Private Sub Command0_Click() 

    Dim olApp As Outlook.Application 
    Dim olNs As Outlook.NameSpace 
    Dim olMailItem As Outlook.MailItem 
    Dim db As DAO.Database    ' ADDED DECLARATION 
    Dim rsEmails As DAO.Recordset 

    Const sBODY As String = "Test Email - Delete Me" 
    Const sSUBJ As String = "Mailing List Test" 
    Const sSQL As String = "SELECT [EmailAddress],[Due Date] &"" ""&[EvalFor] As Subjj FROM tblMailingList;" 

    Set olApp = Outlook.Application 
    Set olNs = olApp.GetNamespace("MAPI") 
    Set db = CurrentDb 
    Set rsEmails = db.OpenRecordset(sSQL) ' CHANGED INITIALIZATION 

    'Create them, but don't send yet 
    Do Until rsEmails.EOF 
     Set olMailItem = olApp.CreateItem(0) 
     With olMailItem 
      .To = rsEmails.Fields("EmailAddress").Value 
      .Subject = rsEmails.Fields("Subjj").Value 
      .Body = sBODY 
      .Save 
     End With 

     olMailItem.Send   

     ' APPEND QUERY 
     db.Execute "INSERT INTO tblAuditList ([DateEmailSent], [EmailAddress], [Due Date]) " _ 
       & " VALUES (#" & Date & "#, '" & rsEmails!EmailAddress & "', #" & rsEmails![Due Date] & "#), dbFailOnError 

     rsEmails.MoveNext 
    Loop 

    ' CLOSING RECORDSET 
    rsEmails.Close 

    ' UNINITIALIZING OBJECTS 
    Set rsEmails = Nothing 
    Set db = Nothing 

End Sub