Question

我有下面的电子邮件脚本。如何为每条记录添加一个调用，将活动日期（发送日期电子邮件）以及字段[EmailAddress]，[截止日期]插入审计表（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）＆＃39;次＆＃39;字符而不是常规的小写字母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

审核邮件发送

2 个答案: