Question

我在供应商报告中有大约150页访问2007.每个报告都有地址，电子邮件联系人，电话号码，产品和每页公司名称。每月一次，我必须向供应商发送电子邮件，以确认联系人地址，电话号码和产品的变更。

我想将该特定报告发送到该特定电子邮件，而不是整个报告。我希望这是自动化的。

我在网上研究后在VBA中编写了代码但仍然没有工作。我得到的参数太多了。预期1.错误。

下面是带有“发送报告”按钮的表单代码。

Dim strSql As String
Dim strSubject As String
Dim strMsgBody As String
strSql = "SELECT DISTINCT Name, EMail FROM [Suppliers and Products]"

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSql)

'loop through the recordset

 Do While Not rst.EOF
    ' grab email string

    strEmail = rst.Fields("EMail")

    ' grab name
    strName = rst.Fields("Name")

    Call fnUserID(rst.Fields("EMail"))

    'send the pdf of the report to curent supplier
    On Error Resume Next

    strSubject = "September 2012 Supplier's Listing"
    strMsgBody = "2008 Procedure Review Attached"
    DoCmd.SendObject acSendReport, "Suppliers Confirmation forms", acFormatHTML, strEmail, , , strSubject, strMsgBody, False

    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, "Delivery Failure to the following email address: " & strEmail
    End If

    On Error GoTo PROC_ERR

    ' move and loop
    rst.MoveNext
Loop

' clean up
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing

PROC_Exit:
Exit Sub

PROC_ERR:
MsgBox Err.Description
Resume PROC_Exit

我有一个包含以下代码的模块

Option Compare Database

Public Function fnUserID(Optional Somevalue As Variant = Null, Optional reset As Boolean = False) As Variant
    Static EMail As Variant
    If reset Or IsEmpty(EMail) Then EMail = Null
    If Not IsNull(Somevalue) Then EMail = Somevalue

    fnUserID = EMail
End Function

Public Function SendReportByEmail(strReportName As String, strEmail As String)
    On Error GoTo PROC_ERR

    Dim strRecipient As String
    Dim strSubject As String
    Dim strMessageBody As String
    'set the email variables
    strRecipients = strEmail
    strSubject = Reports(strReportName).Caption
    strMessageBody = "May 2012 Suppliers' List "

    ' send report as HTML
    DoCmd.SendObjectac acSendReport, strReportName, acFormatHTML, strRecipients, , , strSubject,    strMessageBody, False
    SendReportByEmail = True

    PROC_Exit:
    Exit Function
    Proc Err:

    SendReportByEmail = False

    If Err.Number = 2501 Then
        Call MsgBox("The email was not sent for " & strEmail & ".", vbOKOnly + vbExclamation + vbDefaultButton1, "User Cancelled Operation")
        Else: MsgBox Err.Description
    End If
    Resume PROC_Exit

End Function

报告的查询是获取其数据具有以下SQL。

SELECT Names.Name, Names.Phys_Address, 
       Names.Telephones, Names.Fax, Names.EMail, 
       Names.Web, Names.Caption AS Expr1, [Products by Category].CatName, 
       [Products by Category].ProdName
FROM [Names] 
INNER JOIN [Products by Category] 
ON Names.SuppID=[Products by Category].SupID
WHERE ((Names.EMail = fnUserID()) or (fnUserID() Is Null));

请帮助我，因为我遇到了错误的地方。

Answer 1

一些注释。

On Error GoTo PROC_ERR

Dim qdf As QueryDef
Dim strSQL As String
Dim strSubject As String
Dim strMsgBody As String

strSQL = "SELECT DISTINCT [Name], EMail, SuppID FROM Names " _
       & "INNER JOIN [Products by Category] " _
       & "ON Names.SuppID=[Products by Category].SupID "

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSql)

qrySQL = "SELECT Names.Name, Names.Phys_Address, " _
       & "Names.Telephones, Names.Fax, Names.EMail, " _
       & "Names.Web, Names.Caption AS Expr1, " _
       & "[Products by Category].CatName, " _
       & "[Products by Category].ProdName " _
       & "FROM [Names] " _
       & "INNER JOIN [Products by Category] " _
       & "ON Names.SuppID=[Products by Category].SupID "

'loop through the recordset

 Do While Not rst.EOF
    ' grab email string

    strEmail = rst.Fields("EMail")

    ' grab name
    strName = rst.Fields("Name")

    ' You should check that the email is not null
    Call fnUserID(rst.Fields("EMail"))

    'send the pdf of the report to curent supplier
    'On Error Resume Next

    'The query that the report uses
    Set qdf = CurrentDB.QueryDefs("Suppliers and Products")
    qdf.SQL = qrySQL & " WHERE SuppID=" & rst!SuppID

    strSubject = "September 2012 Supplier's Listing"
    strMsgBody = "2008 Procedure Review Attached"
    DoCmd.SendObject acSendReport, "Suppliers Confirmation forms", _
        acFormatHTML, strEmail, , , strSubject, strMsgBody, False

    ' move and loop
    rst.MoveNext
Loop

''Reset the query
qdf.SQL = qrySQL

rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing

PROC_Exit:
Exit Sub

PROC_ERR:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description, vbOKOnly, _
          "Delivery Failure to the following email address: " & strEmail
    End If
MsgBox Err.Description
Resume PROC_Exit

按公司访问2007 VBA报告电子邮件

1 个答案: