Access 2010 - Bericht als pdf ausgeben und per E-Mail versenden

Hallo zusammen,

ich habe wieder einmal eine schöne Aufgabe bekommen, in Access 2010 Berichte einer Abfrage für jeden Mitarbeiter auszugeben und per E-Mail zu versenden. Jeder Mitarbeiter bekommt dabei eine Übersicht seiner Angebote, welche der zu überarbeiten hat. Hierbei bin ich auch schon soweit gekommen, dass meine Berichte mir gruppiert und super abgelegt werden. Wie schaffe ich es aber, dass der Bericht für jeden Mitarbeiter gleich versendet wird. Meine geschriebene Prozedur macht immer für jeden Datensatz eine neue E-Mail auf, auch wenn die Angebote zum gleichen Mitarbeiter gehören.

Könnt ihr mir helfen bzw. habt eine Idee woran ich gerade scheitere?

Vielen Dank schon einmal für eure Hilfe und Mühe.


Hier der VBA-Code:

Private Sub cmd_AgPflege_Click()

On Error GoTo Errhandler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sSQL As String
Dim QueryName As String
Dim Dateiname As String
Dim stDocRE As String
Dim Pfad As String
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim strAnhaenge As String

stDocRE = "rpt_AG_nicht_gepflegt"

Set db = CurrentDb
Set rs = db.OpenRecordset("qry_AG_nicht_gepflegt" _
, dbOpenDynaset)
If rs.RecordCount = 0 Then MsgBox "Keine Daten vorhanden!": Exit Sub
With rs
.MoveLast: .MoveFirst
Do While Not .EOF
sSQL = "SELECT *" _
& " FROM qry_AG_nicht_gepflegt" _
& " Where ID = " & !ID
QueryName = "qry_AG_nicht_gepflegt_rep"
db.QueryDefs(QueryName).SQL = sSQL


Pfad = "D:\Access\Forecast" & "\Berichte\"
'weise der Variable den aktuellen Speicherpfad und Dateinamen mit Datum zu
Dateiname = Pfad & "Nachpflege Forecast " & Date & " " & !Bearbeiter & ".pdf"
DoCmd.OutputTo acOutputReport, stDocRE, "PDF", Dateiname, False

Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)

With objMail
.Recipients.Add Me!Empfänger
.Subject = "Nachtrag Forcastliste"
.Body = "Hallo Kollege," & vbCrLf & vbCrLf & "bitte prüfe deine Angebote nach der angehangenen pdf-Datei." & vbCrLf & vbCrLf & "Vielen Dank!"
strAnhaenge = Dateiname
.Attachments.Add CStr(strAnhaenge)
.Importance = olImportanceHigh
.ReadReceiptRequested = False
.Display
'.Send
End With

.MoveNext
Loop

End With
Exit_ErrHandler:
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Sub
Errhandler:
MsgBox Err.Description
Resume Exit_ErrHandler

End Sub

Private Sub cmd_AgPflege_Click()
	On Error GoTo Errhandler
	Dim db As DAO.Database
	Dim rs As DAO.Recordset
	Dim sSQL As String
	Dim QueryName As String
	Dim Dateiname As String
	Dim stDocRE As String
	Dim Pfad As String
	Dim objOutlook As Outlook.Application
	Dim objMail As Outlook.MailItem
	Dim strAnhaenge As String
	
	stDocRE = "rpt_AG_nicht_gepflegt"  
	
	Set db = CurrentDb
	Set rs = db.OpenRecordset("qry_AG_nicht_gepflegt", dbOpenDynaset)  
	If rs.RecordCount = 0 Then MsgBox "Keine Daten vorhanden!": Exit Sub  
	
	Set objOutlook = New Outlook.Application
	Set objMail = objOutlook.CreateItem(olMailItem)
	With objMail
		.Recipients.Add Me!Empfänger
		.Subject = "Nachtrag Forcastliste"  
		.Body = "Hallo Kollege," & vbCrLf & vbCrLf & "bitte prüfe deine Angebote nach der angehangenen pdf-Datei." & vbCrLf & vbCrLf & "Vielen Dank!"  
		.Importance = olImportanceHigh
		.ReadReceiptRequested = False
	End With
	With rs
		.MoveFirst
		Do While Not .EOF
			sSQL = "SELECT *" _  
			& " FROM qry_AG_nicht_gepflegt" _  
			& " Where ID = " & !ID  
			QueryName = "qry_AG_nicht_gepflegt_rep"  
			db.QueryDefs(QueryName).SQL = sSQL
			Pfad = "D:\Access\Forecast" & "\Berichte\"  
			'weise der Variable den aktuellen Speicherpfad und Dateinamen mit Datum zu  
			Dateiname = Pfad & "Nachpflege Forecast " & Date & " " & !Bearbeiter & ".pdf"  
			DoCmd.OutputTo acOutputReport, stDocRE, "PDF", Dateiname, False  
			objMail.Attachments.Add CStr(Dateiname)
			.MoveNext
		Loop
	End With
	objMail.Display
	'objMail.Send  
	
	Exit_ErrHandler:
	rs.Close
	Set rs = Nothing
	Set db = Nothing
	Exit Sub
	Errhandler:
	MsgBox Err.Description
	Resume Exit_ErrHandler
End Sub