Termine von Excel nach Outlook
30.12.2004 14:01:02
Excel
mit einem Makro möchte ich viele Termine von einer Excel-Liste in einen Outlook-Kalender schreiben. Der Kalender befindet sich in einem Postfach, zu dem mehrere Nutzer gemeinsamen Zugriff haben (Postfach "Gruppe").
Führe ich diese Prozedur aus, wird der erste Termin richtig in den Kalender eingetragen. Wird beim Durchlaufen der Schleife der zweite Termin mit .Save gespeichert, wird der erste Termin automatisch wieder aus dem Kalender gelöscht.
Habe aber keine Ahnung, warum.
Kann mir jemand weiterhelfen? Kann es evtl. etwas mit der Definition der Objektvariablen zu tun haben?
Hier der Code:
Sub Termine_Von_Excel_Nach_Outlook_Uebertragen()
Dim dblBetrag As Double
Dim Datum
Dim i As Integer
Dim objOutlook As Outlook.Application
Dim myNameSpace As NameSpace
Dim myRecipient As Recipient
Dim Kalender As MAPIFolder
Dim wshQuelle As Worksheet
Dim objItem As Object
Dim Antwort As String
Application.ScreenUpdating = False
Antwort = MsgBox("Sollen diese Daten in den Outlook-" & vbCr _
& "Kalender übertragen werden?", _
vbQuestion + vbYesNo, "Excel -> Outlook")
If Antwort = vbNo Then Exit Sub
Application.ScreenUpdating = False
Set wshQuelle = ActiveWorkbook.Worksheets("Termine")
If Err > 0 Then
MsgBox "Die Tabelle 'Termine' wurde nicht gefunden!" & vbCr _
& "Sie befinden sich evtl. nicht in der richtigen Datei!" & vbCr _
& "Die Daten können nicht nach Outlook übertragen werden!", vbCritical + vbOKOnly
End If
wshQuelle.Range("A2").Select
Do Until ActiveCell.Value = ""
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
Set objOutlook = CreateObject("Outlook.Application")
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myRecipient = myNameSpace.CreateRecipient("Gruppe")
myRecipient.Resolve 'Berechtigung prüfen
If myRecipient.Resolved Then
Set Kalender = myNameSpace.GetSharedDefaultFolder _
(myRecipient, olFolderCalendar)
End If
Set objItem = Kalender.Items(9)
With objItem
dblBetrag = ActiveCell.Offset(0, 1).Value
.Subject = Format(dblBetrag, "##,#0.00")
Datum = ActiveCell.Offset(0, 7).Value + ActiveCell.Offset(0, 8)
.Start = Datum
.Duration = 30
.ReminderMinutesBeforeStart = 10
.ReminderPlaySound = False
.ReminderSet = True
.Save
End With
ActiveCell.Offset(1, 0).Select
'wenn Zeilenende erreicht, aussteigen
If ActiveCell.Value = "Summe" Then Exit Do
Set objItem = Nothing
Set Kalender = Nothing
Set objOutlook = Nothing
Set myNameSpace = Nothing
Set myRecipient = Nothing
Loop
MsgBox "Termine nach Outlook übertragen!"
End Sub
Vielen Dank im voraus.
Gruß
Jürgen