Mehrere outlook Termine aus access 2010 versenden

Hallo, benötige mal wieder Eure Hilfe.

Ich habe in access2010 ein Formular, dass sich auf die Tabelle "Buchung_Fluginfos" bezieht
In der Tabelle werden meine gebuchten Flüge abgelegt.
Ein "Vorgang" besteht aus einer Vorgangsnummer hinter der nun natürlichen mehrere Flüge liegen können.

Bespiel:
Vorgangsnummer Datum Airline von bis Abflug Ankunft
54856 10.01.14 LH 123 Düsseldorf München 10:00 11:00
54856 10.01.14 LH 456 München Düsseldorf 19:00 20:00


Ich möchte nun aus Access 2 Termine an eine Outlook mail, die ich versende, anhängen

Der Code dazu sieht wie folgt aus:
Set rs = Me.RecordsetClone

sStr = sStr & rs!Datum & vbNewLine & rs!Airline & vbTab & rs!von & " - " & _
rs!bis & vbTab & Format(rs!Abflug, "hh:mm") & " - " & vbTab & Format(rs!Ankunft, "hh:mm") & vbNewLine & vbNewLine


rs.MoveFirst
Do Until rs.EOF

Set OutApp = CreateObject("Outlook.Application")
Set OutApptmt = OutApp.CreateItem(0)
With OutApptmt
.Subject = rs!filekey
.Start = rs!Abflug
.End = rs!Ankunft
' make it a meeting request
.MeetingStatus = 1 '1=olMeeting
.Body = sStr
'.Save
Set OutMail = .ForwardAsVcal

End With
rs.MoveNext
Loop
rs.Close

On Error Resume Next
With OutMail
.GetInspector.Display
.To = ""
.cc = ""
'.Attachments.Add
.bcc = ""
.Subject = "Flug"
.htmlBody = "<span style=" & Chr(34) & " font-family:Arial; " & _
" font-size:10pt; " & Chr(34) & _
">Hallo " & ", <BR><BR>" & _
"anbei meine Flüge " & _
<BR><BR>" & _
"Schöne Grüße " & olOldBody

Set OutMail = Nothing
Set OutApp = Nothing

End With

End Sub

Das funktioniert aber nur in der Form, daß mir nur 1 Termin für beide Flüge gemacht wird und nicht 2 Termine. Also einen für den Hinflug und einen für den Rückflug

Hat jemand eine Idee?

Bin am verzweifeln! Würde mir echt riesig helfen.

Vielen Dank im voraus

VG
Rico

Set rs = Me.RecordsetClone

rs.MoveFirst
Set OutApp = CreateObject("Outlook.Application")  
Set OutMail = OutApp.CreateItem(0)

Do Until rs.EOF
        Set OutApptmt = OutApp.CreateItem(1)
        sStr = rs!Datum & vbNewLine & rs!Airline & vbTab & rs!von & " - " & rs!bis & vbTab & Format(rs!Abflug, "hh:mm") & " - " & vbTab & Format(rs!Ankunft, "hh:mm") & vbNewLine & vbNewLine  
	With OutApptmt
		.Subject = rs!filekey
		.Start = rs!Datum & " " & rs!Abflug  
                 if TimeValue(rs!Abflug) > TimeValue(rs!Ankunft) then
                    .End = DateAdd("d",1,DateValue(rs!Datum)) & " " & rs!Ankunft  
                 else
                    .End = rs!Datum & " " & rs!Ankunft  
                 end if
		' make it a meeting request  
		.MeetingStatus = 1 '1=olMeeting  
		.Body = sStr
                .Save
                OutMail.Attachments.Add OutApptmt
      	End With
	rs.MoveNext
        OutApptmt.Delete
Loop
rs.Close

On Error Resume Next
With OutMail
	.To = ""  
	.cc = ""  
	.bcc = ""  
	.Subject = "Flug"  
	.htmlBody = "<span style=" & Chr(34) & " font-family:Arial; " & _  
	" font-size:10pt; " & Chr(34) & _  
	">Hallo " & ", <BR><BR>" & _  
	"anbei meine Flüge " & _  
	"<BR><BR>" & _  
	"Schöne Grüße " & olOldBody  
       .Display
End With

Set OutMail = Nothing
Set OutApp = Nothing

if TimeValue(rs!Abflug) > TimeValue(rs!Ankunft) then
    .End = DateAdd("d",1,DateValue(rs!Datum)) & " " & rs!Ankunft  
else
    .End = rs!Datum & " " & rs!Ankunft  
end if