Excel 访问VBA将带有附件的邮件（QueryDef）发送到循环中

你想完成什么？

我正在尝试为每个rs创建一个邮件项目。此邮件项目应具有作为附件的临时查询。通过TransferSpreadSheet，我将临时查询加载到文件夹中

粘贴代码中显示问题的部分。

问题在于查询定义。它在附件中始终显示相同的数据，而不是每个rs的数据。我建议我必须将查询定义包含到我的循环中，但因此我需要您的帮助

Sub ExcelExportuSenden()

Dim day As Integer
day = Weekday(Date, vbSunday)
Dim olApp As Outlook.Application
Dim toMulti, waarde As String
Dim mItem As Outlook.MailItem  ' An Outlook Mail item
Dim dbs As Database
Dim qdfTemp As QueryDef
Dim qdfNew As QueryDef
Dim originalSql As String
Dim Identified_name As Recordset
Dim qdf As DAO.QueryDef
Set dbs = CurrentDb
Set olApp = CreateObject("Outlook.Application")
Set mItem = olApp.CreateItem(olMailItem)
Dim rs  As Recordset

Set rs = CurrentDb.OpenRecordset("Mailversand")  'Get name for the email distro

If rs.RecordCount > 0 Then
    rs.MoveFirst
    Do Until rs.EOF
        With mItem
            Set mItem = olApp.CreateItem(olMailItem)
            .BodyFormat = olFormatHTML
            toMulti = rs![email]
            waarde = toMulti
            For Each qdf In dbs.QueryDefs
                If qdf.Name = "Anfrage_zur_Ausschreibung" Then
                   dbs.QueryDefs.Delete "Anfrage_zur_Ausschreibung"
                   Exit For
                End If
            Next

            Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung")
            With dbs
               'Run query on selected Name product manager
                qdfTemp.SQL = "SELECT * FROM [Filter_Ausschreibung_original] WHERE [Lieferant] = '" & rs![Lieferant] & "'"
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Anfrage_zur_Ausschreibung", "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True

            End With

        .To = toMulti
        MsgBox toMulti
        .Subject = "Anfrage zu Ausschreibung"
        .HTMLBody = "Sehr geehrte Damen und Herren"
        .Display
        .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx")

    End With

       rs.MoveNext
    Loop
Else
    MsgBox "No email address!"
End If
olApp.Quit
Set olApp = Nothing
Exit Sub

End Sub

你期望结果是什么？ 每个rs应具有不同的附件。属于“中尉”的那部分

您得到的实际结果是什么？（请包括任何错误。） 我只收到一份附件，而且内容总是一样的

更新 我想用冻糕的解决方案。现在的问题是以下部分出现错误：

'Export temp table to Excel
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
          "Anfrage_zur_Ausschreibung_TEMP", _
          "Q:\LU\_Rothenhöfer\Test\Anfrage_zur_Ausschreibung_TEMP.xlsx", True

完整代码现在是：

Sub ExcelExportuSenden()

Dim day As Integer
day = Weekday(Date, vbSunday)
Dim olApp As Outlook.Application
Dim toMulti, waarde As String
Dim mItem As Outlook.MailItem  ' An Outlook Mail item
Dim dbs As Database
Dim qdfTemp As QueryDef
Dim qdfNew As QueryDef
Dim originalSql As String
Dim Identified_name As Recordset
Dim qdf As DAO.QueryDef
Set dbs = CurrentDb
Set olApp = CreateObject("Outlook.Application")
Set mItem = olApp.CreateItem(olMailItem)
Dim rs  As Recordset

Set rs = CurrentDb.OpenRecordset("Mailversand")  'Get name for the email distro

If rs.RecordCount > 0 Then
    rs.MoveFirst

Do Until rs.EOF
    With mItem
        Set mItem = olApp.CreateItem(olMailItem)
        .BodyFormat = olFormatHTML
        toMulti = rs![email]
        waarde = toMulti

        Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung")
        qdfTemp.SQL = "PARAMETERS LieferantParam Text ( 255 ); " & _
                      "SELECT * INTO Anfrage_zur_Ausschreibung_TEMP " & _
                      "From Filter_Ausschreibung_original " & _
                      "WHERE [Lieferant] = rs![Lieferant]"

        Set qdfTemp = Nothing

        'Export temp table to Excel
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
              "Anfrage_zur_Ausschreibung_TEMP", _
              "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True

        .To = toMulti
        MsgBox toMulti
        .Subject = "Anfrage zu Ausschreibung"
        .HTMLBody = "Sehr geehrte Damen und Herren"
        .Display
        .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx")
    End With
    rs.MoveNext
Loop
Else
    MsgBox "No email address!"
End If
olApp.Quit
Set olApp = Nothing
Exit Sub

End Sub

我做错了什么？

只需在更新其SQL后释放qTemp，否则不会传播任何更改：

' UPDATE QUERY
Set qdfTemp = dbs.CreateQueryDef("Anfrage_zur_Ausschreibung")
qdfTemp.SQL = "<SQL Query>"
Set qdfTemp = Nothing                 ' RELEASES QUERYDEF

' EXPORT QUERY TO EXCEL
DoCmd.TransferSpreadsheet acExport ...

VBA（循环部分仅通过当前参数在操作上方运行）

---

如果从DoCmd中删除“数据”，会发生什么情况，因为此字段仅适用于导入而不适用于导出……是的，@Xabier所说的是正确的。您的参数“DATA”用于“Range”，文档说明：“…导出到电子表格时，必须将此参数留空。如果输入范围，导出将失败。”此外，我看不出您在哪里发出“.Send”？@WayneG.Dunn他使用的是.Display而不是.Send，因此，您可以在发送之前预览…是的。显示在预览中显示每封邮件，但仅使用相同的附件…@Xabier我不明白您所说的“从您的文档中删除日期”是什么意思。你能解释一下吗？非常感谢（我是vba的初学者）感谢您的解决方案。我想这是正确的方法，但我试图使用它，并得到了一个错误（见我的更新上面）请翻译错误消息，因为这是一个英文网站。你的实现方式肯定和我的方法不一样。您根本不进行参数化，而是插入

rs！[Lieferant]

直接转换为无法识别的SQL字符串。另外，我建议将查询保存为存储查询，而不是每次重建。在VBA中，您所做的只是将值绑定到参数占位符。您可以使用您的方法，但可以删除不必要的

参数
子句，然后连接
rs！[Lieferant]
像您最初那样使用引号包装器在
中插入表达式。现在它可以工作了，我认为Anfrage_zur_Ausschreibung_查询是查询，Anfrage_zur_Ausschreibung_Temp是另一个查询。很抱歉我的误解，非常感谢你的帮助！！！是的，_Query是一个特殊操作，而不是
SELECT
Query（即，），并且_Temp是一个临时表。我以这种方式更改了您的方法，以允许参数化。使用存储的查询进行导出时，除非在运行时通过VBA将DAO记录集导出到Excel，否则无法使用绑定的参数值保存查询，除非在运行时进行虚拟保存。
Do Until rs.EOF    
    With mItem
        Set mItem = olApp.CreateItem(olMailItem)
        .BodyFormat = olFormatHTML
        toMulti = rs![email]
        waarde = toMulti

        'Retrieve make-table query and bind parameter to name product manager
        Set qdfTemp = dbs.QueryDef("Anfrage_zur_Ausschreibung_QUERY")
        qdfTemp![LieferantParam] = rs![Lieferant]
        qdfTemp.Execute, dbFailOnError

        'Export temp table to Excel   
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
              "Anfrage_zur_Ausschreibung_TEMP", _
              "Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx", True

        .To = toMulti
        MsgBox toMulti
        .Subject = "Anfrage zu Ausschreibung"
        .HTMLBody = "Sehr geehrte Damen und Herren"
        .Display
        .Attachments.Add ("Q:\LU\Test\Anfrage_zur_Ausschreibung.xlsx")    
    End With    
    rs.MoveNext
Loop