Access 2002 通过电子邮件发送每个供应商的所有查询记录

问题描述

我有一个可以向供应商发送多封电子邮件的 vba，但我想对其进行更改，以便它嵌入查询并且每个供应商仅发送一封电子邮件。这是我目前所拥有的：

Option Compare Database

Public Sub SendFollowUpEmail() 
    Dim db As DAO.Database 
    Dim rs As DAO.Recordset

Dim emailTo As String 
Dim emailSubject As String 
Dim emailText As String

Dim outApp As outlook.application 
Dim outMail As Outlook.MailItem 
Dim outlookStarted As Boolean


On Error Resume Next 
Set outApp = Getobject(,"outlook.application")
On Error GoTo 0 
If outApp Is nothing Then
    Set outApp = CreateObject("outlook.application")
    outlookStarted = True 
End If

Set db = CurrentDb
strsql = "SELECT qry002UnmatchedOpenInvoices.kyUnique,qry002UnmatchedOpenInvoices.[vendor Nbr],qry002UnmatchedOpenInvoices.[vendor Name]," & _
                " qry002UnmatchedOpenInvoices.[Purchasing Document],qry002UnmatchedOpenInvoices.Item,qry002UnmatchedOpenInvoices.[Document Date]," & _
                " qry002UnmatchedOpenInvoices.Material,qry002UnmatchedOpenInvoices.[Short Text],qry002UnmatchedOpenInvoices.[Material Group]," & _
                " qry002UnmatchedOpenInvoices.[Invoice Sent],qry002UnmatchedOpenInvoices.[Order Quantity],qry002UnmatchedOpenInvoices.[Order Unit]," & _
                " qry002UnmatchedOpenInvoices.[Quantity in SKU],qry002UnmatchedOpenInvoices.[Stockkeeping unit],qry002UnmatchedOpenInvoices.[Net price]," & _
                " qry002UnmatchedOpenInvoices.Currency,qry002UnmatchedOpenInvoices.[Price Unit],qry002UnmatchedOpenInvoices.[Release status]," & _
                " qry002UnmatchedOpenInvoices.[No of Positions],tblvendors.vendor,tblvendors.Email " & _
                " FROM qry002UnmatchedOpenInvoices LEFT JOIN tblvendors ON qry002UnmatchedOpenInvoices.[vendor Nbr] =tblvendors.[vendor Number] " & _
                " WHERE (((qry002UnmatchedOpenInvoices.Material) Is Null) AND ((qry002UnmatchedOpenInvoices.[Invoice Sent]) Is Null));"
Set rs = db.OpenRecordset(strsql,dbOpenDynaset) 
Do Until rs.EOF

    emailTo = Trim(rs.Fields("Email").Value & "; [e-mail];[e-mail]")

    emailSubject = "Open Invoices"
    
    emailText = Trim("Please send invoices of the below Purchase Orders:") & vbCrLf


    emailText = emailText & _
                "PO# " & rs.Fields("[Purchasing Document]").Value

    Set outMail = outApp.CreateItem(olMailItem)
    outMail.To = emailTo
    outMail.Subject = emailSubject
    outMail.Body = emailText
    outMail.Send

    'rs.Edit
    'rs("FUP_Date_Sent") = Now()
    rs.MoveNext 
Loop

rs.Close 
Set rs = nothing 
Set db = nothing

If outlookStarted Then
    outApp.Quit 
End If

Set outMail = nothing 
Set outApp = nothing
End Sub

解决方法

您需要做的是使用两个记录集。第一个选择不同的供应商，第二个选择该供应商的发票。类似的东西：

Sub sSendFollowUpEMail()
    On Error GoTo E_Handle
    Dim db As DAO.Database
    Dim rsVendor As DAO.Recordset
    Dim rsInvoice As DAO.Recordset
    Dim objOL As New Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim strSQL As String
    Dim emailTo As String
    Dim emailText As String
    Set db = CurrentDb
    strSQL = "SELECT DISTINCT V.[Vendor Number],V.EMail " _
        & " FROM qry002UnmatchedOpenInvoices AS I LEFT JOIN tblVendors AS V ON I.[Vendor Nbr]=V.[Vendor Number] " _
        & " WHERE I.Material IS NULL " _
        & " AND I.[Invoice Sent] IS NULL;"
    Set rsVendor = db.OpenRecordset(strSQL)
    If Not (rsVendor.BOF And rsVendor.EOF) Then
        Do
            strSQL = "SELECT I.[Purchasing Document] " _
                & " FROM qry2002UnMatchedOpenInvoices AS I " _
                & " WHERE I.Material IS NULL " _
                & " AND I.[Invoice Sent] IS NULL " _
                & " AND I.[Vendor Nbr]=" & rsVendor("Vendor Number") _
                & " ORDER BY I.[Purchasing Document] ASC;"
            Set rsInvoice = db.OpenRecordset(strSQL)
            If Not (rsInvoice.BOF And rsInvoice.EOF) Then
                emailText = "Please pay:"
                Do
                    emailText = emailText & vbCrLf & rsInvoice("Purchasing Document")
                    rsInvoice.MoveNext
                Loop Until rsInvoice.EOF
            End If
            emailTo = rsVendor!EMail
            Set objMail = objOL.CreateItem(olMailItem)
            objMail.To = emailTo
            objMail.Subject = EmailSubject
            objMail.Body = emailText
            objMail.Send
            rsVendor.MoveNext
        Loop Until rsVendor.EOF
    End If
sExit:
    On Error Resume Next
    rsVendor.Close
    rsInvoice.Close
    Set rsVendor = Nothing
    Set rsInvoice = Nothing
    Set db = Nothing
    Set objMail = Nothing
    objOL.Quit
    Set objOL = Nothing
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & vbcrfl & "sSendFollowUpEMail",vbOKOnly + vbCritical,"Error: " & Err.Number
    Resume sExit
End Sub

一些注意事项。

1. 在您的原始记录集中，您包含了此过程中未使用的大量字段，不推荐这样做 - 仅获取您需要的数据，因为这会提高性能；
2. 其次，您似乎混合了 Outlook 的早期和后期绑定；
3. 最后，我在 SQL 语句中为查询/表名称使用了别名 - 这使 SQL 更易于管理，而且如果您需要更改原始表/查询之一，更改只需命名一次。

问候，