審覈郵件發送

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