Question

你想要完成什么？

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

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

问题是查询def。它向我显示了附件中的相同数据，而不是每个rs的数据。我建议我必须将查询def包含在我的循环中，但因此我需要你的帮助。

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都应该有不同的附件。该部分属于＆＃34; Lieferant＆＃34;。

您获得的实际结果是什么？（请包含任何错误。） 我只有一个附件，而且总是有相同的内容。

更新我正在尝试使用Parfait的解决方案。问题现在是以下部分的错误：

'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

我做错了什么？

Answer 1

更新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变量连接到SQL语句来删除和重新创建查询的方法。考虑parameterization以获得更清晰，可维护，稍微有效的代码，迭代地为excel导出构建临时表。

SQL （另存为PARAMETERS子句的永久性生成表操作查询）

PARAMETERS LieferantParam TEXT;
SELECT * INTO Anfrage_zur_Ausschreibung_TEMP
FROM [Filter_Ausschreibung_original] 
WHERE [Lieferant] = [LieferantParam];

VBA （循环部分仅在当前参数的上方运行）

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

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

1 个答案: