Access VBA Send Mail with Attachement (QueryDef) into a loop

Question

What are you trying to accomplish?

I'm trying to create for each rs a mail item. This mail item should have a temporary query as attachement. Via TransferSpreadSheet I load my temporary Query into Folder.

Paste the part of the code that shows the problem.

Problem is the query def. It shows me always the same data in attachement, not the data for each rs. I suggest that I have to include the query def into my loop, but therefore I need your help.

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

What do you expect the result to be? Each rs should have a different attachement. The part which belongs to "Lieferant".

What is the actual result you get? (Please include any errors.) I only got one attachement, and this is always with the same content.

UPDATE I'm trying to work with Parfait's solution. Problem now is an error on following part:

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

Full code is now:

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

What am I doing wrong?

Answer 1

Simply release your qTemp after you update its SQL, otherwise no changes are propagated:

' 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 ...

However, reconsider this approach of deleting and re-creating queries by concatenating VBA variables to SQL statement. Consider parameterization for cleaner, maintainable, slightly efficient code that iteratively builds a temp table for excel export.

SQL (save as a permanent make-table action query with PARAMETERS clause)

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

VBA (loop section only running above action by current parameter)

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