审核邮件发送

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]、[errno]、[errdsc]）和一个默认为 Now() 的日期时间，那么这些添加就足够了。

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].[errno] 更改为 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