VBA MailItem in Loop for multiple emails

[DR1989]

I'm trying to send an email for each record in a recordset with the selected Query.
The code creates a recordset to show me how many suppliers I have in my inquiry. Next I build an SQL string sSQL for each supplier ("Lieferant"). This should be an Attachement as XLS. After that I use a Loop to create a temporary query which I have to send to each supplier. Here is my code:



Sub ExcelExportuSenden()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qd As DAO.QueryDef
Dim sSQL As String
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim fileName As String


Set db = CurrentDb
Set qd = db.CreateQueryDef("Lieferant", "SELECT * FROM [Filter_Ausschreibung_original] WHERE 1 = 0")
Set qd = Nothing
Set rs = db.OpenRecordset( _
"SELECT DISTINCT [Lieferant] FROM [Filter_Ausschreibung_original] ", _
dbOpenForwardOnly)
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With rs
Do While Not .EOF
sSQL = "SELECT * FROM [Filter_Ausschreibung_original] " & _
" WHERE Lieferant = '" & .Fields("Lieferant") & "'"
db.QueryDefs("Anfrage").SQL = sSQL
Debug.Print sSQL
.MoveNext
Loop
.Close
End With
With oMail
.Subject = ""
.Body = "Sehr geehrte Damen und Herren," & vbCr & "" & vbCr & "anbei erhalten Sie" & _
vbCr & "" & vbCr & "- die Auftragsbestätigung für die erbrachte Dienstleistung vor Ort" & _
vbCr & "- die Prüfbescheinigungen für die wiederkehrende Prüfung vor Ort" & _
vbCr & "- die aktuelle Übersicht der Schlauchleitungen." & _
vbCr & "" & vbCr & "Die Rechnung senden wir separat an die angegebene Rechnungsadresse." & _
vbCr & "" & vbCr & "Für eventuelle Rückfragen stehen wir Ihnen zur Verfügung, gerne auch persönlich nach Terminvereinbarung." & _
vbCr & "" & vbCr & "Mit freundlichen Grüßen" & _
vbCr & "" & vbCr & ""
.Display
End With
db.QueryDefs.Delete "Lieferant"
Set rs = Nothing
Set db = Nothing
End Sub





I'm trying to send an email for each record in a recordset with the selected Query.
The code creates a recordset to show me how many suppliers I have in my inquiry. Next I build an SQL string sSQL for each supplier ("Lieferant"). This should be an Attachement as XLS. After that I use a Loop to create a temporary query which I have to send to each supplier. Here is my code:
Sub ExcelExportuSenden()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qd As DAO.QueryDef
Dim sSQL As String
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim fileName As String


Set db = CurrentDb
Set qd = db.CreateQueryDef("Lieferant", "SELECT * FROM [Filter_Ausschreibung_original] WHERE 1 = 0")
Set qd = Nothing
Set rs = db.OpenRecordset( _
"SELECT DISTINCT [Lieferant] FROM [Filter_Ausschreibung_original] ", _
dbOpenForwardOnly)
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With rs
Do While Not .EOF
sSQL = "SELECT * FROM [Filter_Ausschreibung_original] " & _
" WHERE Lieferant = '" & .Fields("Lieferant") & "'"
db.QueryDefs("Anfrage").SQL = sSQL
Debug.Print sSQL
.MoveNext
Loop
.Close
End With
With oMail
.Subject = ""
.Body = "Sehr geehrte Damen und Herren," & vbCr & "" & vbCr & "anbei erhalten Sie" & _
vbCr & "" & vbCr & "- die Auftragsbestätigung für die erbrachte Dienstleistung vor Ort" & _
vbCr & "- die Prüfbescheinigungen für die wiederkehrende Prüfung vor Ort" & _
vbCr & "- die aktuelle Übersicht der Schlauchleitungen." & _
vbCr & "" & vbCr & "Die Rechnung senden wir separat an die angegebene Rechnungsadresse." & _
vbCr & "" & vbCr & "Für eventuelle Rückfragen stehen wir Ihnen zur Verfügung, gerne auch persönlich nach Terminvereinbarung." & _
vbCr & "" & vbCr & "Mit freundlichen Grüßen" & _
vbCr & "" & vbCr & ""
.Display
End With
db.QueryDefs.Delete "Lieferant"
Set rs = Nothing
Set db = Nothing
End

The current code does not create an email for each "Lieferant. It only starts with an email (with the first "Lieferant"), and after sending the email it doesn't open the next mail. So, i guess something is wrong with the Event "with rs" and "with oMail". I guess I should use "for each rs". Am I right?

[OBP]

Your emailing VBA is NOT inside the Loop going through the rs recordset Records.

[DR1989]

May you can help, how it is correct inside the loop? I tried different ways, but it doesn't works.

[OBP]

Sub ExcelExportuSenden()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qd As DAO.QueryDef
Dim sSQL As String
Dim oApp As Outlook.Application
Dim oMail As MailItem
Dim fileName As String


Set db = CurrentDb
Set qd = db.CreateQueryDef("Lieferant", "SELECT * FROM [Filter_Ausschreibung_original] WHERE 1 = 0")
Set qd = Nothing
Set rs = db.OpenRecordset( _
"SELECT DISTINCT [Lieferant] FROM [Filter_Ausschreibung_original] ", _
dbOpenForwardOnly)
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With rs
Do While Not .EOF
sSQL = "SELECT * FROM [Filter_Ausschreibung_original] " & _
" WHERE Lieferant = '" & .Fields("Lieferant") & "'"
db.QueryDefs("Anfrage").SQL = sSQL
Debug.Print sSQL
.MoveNext
With oMail
.Subject = ""
.Body = "Sehr geehrte Damen und Herren," & vbCr & "" & vbCr & "anbei erhalten Sie" & _
vbCr & "" & vbCr & "- die Auftragsbestätigung für die erbrachte Dienstleistung vor Ort" & _
vbCr & "- die Prüfbescheinigungen für die wiederkehrende Prüfung vor Ort" & _
vbCr & "- die aktuelle Übersicht der Schlauchleitungen." & _
vbCr & "" & vbCr & "Die Rechnung senden wir separat an die angegebene Rechnungsadresse." & _
vbCr & "" & vbCr & "Für eventuelle Rückfragen stehen wir Ihnen zur Verfügung, gerne auch persönlich nach Terminvereinbarung." & _
vbCr & "" & vbCr & "Mit freundlichen Grüßen" & _
vbCr & "" & vbCr & ""
.Display
End With
Loop
.Close
End With

db.QueryDefs.Delete "Lieferant"
Set rs = Nothing
Set db = Nothing
End Sub


The other thing to check is how many records your loop is actually processing, I personally do not like do until rs.EOF
So add 3 lines of code after this line
Set rs = db.OpenRecordset( _
"SELECT DISTINCT [Lieferant] FROM [Filter_Ausschreibung_original] ", _
dbOpenForwardOnly)

rs.movelast
rs.movefirst
msgbox rs.recordcount

The last line will tell you how many records are in the recordset.
The other point is what it the Query sSQL doing, you do not actually creat a dataset for it or try to pass any values to the email either?

[DR1989]

OK I will try it tomorrow in my office...thanks for your help!
My query sSQL should be my attachement for wach RS. But therefore I know how it works. ;-)