Terminimport per VBA

[etofi]

Hallo zusammen,

ich möchte meine Termine aus Notes in eine Access DB importieren.
Dazu habe ich folgendes programmiert:

Code

Public Function NotesKalenderEinlesen(strServer As String, strMailDB As String, datStart As Date, datEnde As Date) As Integer
    
    Dim objNotes        As Object
    Dim LNdb            As Object
    Dim LNView          As Object
    Dim DateTimeStart   As Object
    Dim DateTimeEnd     As Object
    Dim DateRange       As Object
    Dim Collection      As Object
    Dim LNDoc           As Object
    Dim LNItem          As Object
    Dim datDatetime     As Date
    Dim rsTermine       As DAO.Recordset
    Dim rsFehler        As DAO.Recordset
    
   
    On Error GoTo ErrBeh
  
    'tblTermine leeren
    CurrentDb.Execute "DELETE tblTermine.* FROM tblTermine"
    
    Set rsTermine = CurrentDb.OpenRecordset("tblTermine", dbOpenTable)
    
    'Holen einer aktiven Notessession
    Set objNotes = GetObject("", "Notes.NotesSession")
    'Verweisen auf die gewünschte Datenbank
    Set LNdb = objNotes.GETDATABASE(strServer, strMailDB)
 
    If Not (LNdb Is Nothing) Then
        
        Set LNView = LNdb.GETVIEW("$Calendar")
        
        If LNView Is Nothing = False Then
            
            'Zeitraum setzen
            Set DateTimeStart = objNotes.CreateDateTime(Day(datStart) & "." & Month(datStart) & "." & Year(datStart))
            Set DateTimeEnd = objNotes.CreateDateTime(Day(datEnde) & "." & Month(datEnde) & "." & Year(datEnde))
            Set DateRange = objNotes.CreateDateRange
            Set DateRange.StartDateTime = DateTimeStart
            Set DateRange.ENDDATETIME = DateTimeEnd
            
            'Collection füllen
            Set Collection = LNView.GETALLDOCUMENTSBYKEY(DateRange)
             
            'Einlesen des ersten Mail-Dokuments
            Set LNDoc = Collection.GETFIRSTDOCUMENT
                       
            Do While Not LNDoc Is Nothing
                 
                rsTermine.AddNew
                
                 'Start
                Set LNItem = LNDoc.GETFIRSTITEM("StartDate")
                If LNItem Is Nothing = False Then
                    datDatetime = CDate(LNItem.Text)
                    rsTermine.Fields("Start_Datum").Value = DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime))
                End If
                Set LNItem = LNDoc.GETFIRSTITEM("StartTime")
                If LNItem Is Nothing = False Then
                    datDatetime = CDate(LNItem.Text)
                    rsTermine.Fields("Start_Uhrzeit").Value = TimeSerial(Hour(datDatetime), Minute(datDatetime), Second(datDatetime))
                End If
                
                 'Ende
                Set LNItem = LNDoc.GETFIRSTITEM("EndDate")
                If LNItem Is Nothing = False Then
                 datDatetime = CDate(LNItem.Text)
                    rsTermine.Fields("Ende_Datum").Value = DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime))
                End If
                Set LNItem = LNDoc.GETFIRSTITEM("EndTime")
                If LNItem Is Nothing = False Then
                 datDatetime = CDate(LNItem.Text)
                    rsTermine.Fields("Ende_Uhrzeit").Value = TimeSerial(Hour(datDatetime), Minute(datDatetime), Second(datDatetime))
                End If
                
                'Terminbezeichnung
                Set LNItem = LNDoc.GETFIRSTITEM("Subject")
                If LNItem Is Nothing = False Then
                    rsTermine.Fields("Terminbezeichnung").Value = LNItem.Text
                End If
                
                'Termindetails
                Set LNItem = LNDoc.GETFIRSTITEM("Body")
                If LNItem Is Nothing = False Then
                    rsTermine.Fields("Termindetails").Value = LNItem.Text
                End If
                
                'Ort
                Set LNItem = LNDoc.GETFIRSTITEM("Location")
                If LNItem Is Nothing = False Then
                    rsTermine.Fields("Ort").Value = LNItem.Text
                End If
                
                rsTermine.Update
                
                'Ermitteln des nächsten Mail-Dokuments
                Set LNDoc = Collection.GETNEXTDOCUMENT(LNDoc)
                                
            Loop
        End If
    End If
 
GoTo Ende
 
ErrBeh:
    Set rsFehler = CurrentDb.OpenRecordset("tblFehler", dbOpenTable)
    rsFehler.AddNew
    rsFehler.Fields(0).Value = 0
    rsFehler.Fields(1).Value = Err.Description
    rsFehler.Update
    rsFehler.Close
    Set rsFehler = Nothing
    Err.Clear
    Resume Next
 
Ende:
    Set objNotes = Nothing
    Set LNdb = Nothing
    Set LNView = Nothing
    Set LNItem = Nothing
    Set LNDoc = Nothing
 
 End Function

Leider werden nicht alle Termine importiert.
Meine Vermutung ist dass verschobene Termine, Serientermine & Termine die vor dem Anfragezeitraum erstellt wurden in der Anzeige fehlen.
Hat jemand eine Idee wie ich alle meine Termine im gewünschten Zeitraum einlesen kann?

Grüße
Eric

[Andrew Harder]

Ich würde jetzt mal leichtsinnig behaupten: Du hast alle Dokumente.

Wahrscheinlich nur ein kleiner Denkfehler.

Zum Beispiel Wiederholungstermine:
Wiederholungstermin von 10.02.2014, jeden Tag der Woche von 08:00 - 12:00 Uhr
Da würde bei Dir ein Datensatz mit 10.02.1014 08:00 bis 10.02.2014 12:00 Uhr angelegt werden.

Sieh Dir das Feld "CalendarDateTime" in Wiederholungsterminen an, dann verstehst Du sicherlich gleich was ich meine.

[etofi]

Sieh Dir das Feld "CalendarDateTime" in Wiederholungsterminen an, dann verstehst Du sicherlich gleich was ich meine.

Das genau ist mein Problem.
Im Feld CalendarDateTime sind alle Termine drin, im Feld StartDate steht nur das erste Datum drin.
Der o.g. Filter geht aber nur auf das StartDate, damit falle diese ganzen Termine durch das Filter durch wenn das StartDate nicht im gesuchten Zeitraum ist die Wiederholung aber schon.
Wie kann ich nach CalendarDateTime filtern und bekomem aber nur den Tag / bzw. die Tage aus der Serie als Datensatz zurück die im gesuchten Zeitraum liegen.

[etofi]

Manchmal sieht man den Wald...

Für alle die es brauchen, so geht es:

Code

Public Function NotesKalenderEinlesen(strServer As String, strMailDB As String, datStart As Date, datEnde As Date) As Integer
    
    Dim objNotes        As Object
    Dim LNdb            As Object
    Dim LNView          As Object
    Dim DateTimeStart   As Object
    Dim DateTimeEnd     As Object
    Dim DateRange       As Object
    Dim Collection      As Object
    Dim LNDoc           As Object
    Dim LNItem          As Object
    Dim datDatetime     As Date
    Dim rsTermine       As DAO.Recordset
    Dim rsFehler        As DAO.Recordset
     Dim strCalDateTime()    As String
    Dim strEndDateTime()    As String
    Dim i                   As Integer
    Dim intAnzahl           As Integer
    
  
    On Error GoTo ErrBeh
  
    'tblTermine leeren
    CurrentDb.Execute "DELETE tblTermine.* FROM tblTermine"
    
    Set rsTermine = CurrentDb.OpenRecordset("tblTermine", dbOpenTable)
    
    'Holen einer aktiven Notessession
    Set objNotes = GetObject("", "Notes.NotesSession")
    'Verweisen auf die gewünschte Datenbank
    Set LNdb = objNotes.GETDATABASE(strServer, strMailDB, False)
 
    If Not (LNdb Is Nothing) Then
        
 
        Set LNView = LNdb.GETVIEW("Calendar")
 
        If LNView Is Nothing = False Then
            
            'Zeitraum setzen
            Set DateTimeStart = objNotes.CreateDateTime(Day(datStart) & "." & Month(datStart) & "." & Year(datStart))
            Set DateTimeEnd = objNotes.CreateDateTime(Day(datEnde) & "." & Month(datEnde) & "." & Year(datEnde))
            Set DateRange = objNotes.CreateDateRange
            Set DateRange.StartDateTime = DateTimeStart
            Set DateRange.ENDDATETIME = DateTimeEnd
            
            'Collection füllen
            Set Collection = LNView.GETALLDOCUMENTSBYKEY(DateRange)
             
            'Einlesen des ersten Mail-Dokuments
            Set LNDoc = Collection.GETFIRSTDOCUMENT
                       
            Do While Not LNDoc Is Nothing
                
                'Schleife Je nachdem wie viele Einträe in CalendarDateTime im Suchzeitraum sind
                Set LNItem = LNDoc.GETFIRSTITEM("CalendarDateTime")
                strCalDateTime = Split(LNItem.Text, ";")
                
                If UBound(strCalDateTime) = 0 Then
                    intAnzahl = 0
                Else
                    intAnzahl = UBound(strCalDateTime) - 1
                End If
                
                For i = 0 To intAnzahl
                
                    datDatetime = CDate(strCalDateTime(i))
                    If DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime)) >= datStart And _
                       DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime)) <= datEnde Then
                    
                        rsTermine.AddNew
                    
                        'Start
                        rsTermine.Fields("Start_Datum").Value = DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime))
                        rsTermine.Fields("Start_Uhrzeit").Value = TimeSerial(Hour(datDatetime), Minute(datDatetime), Second(datDatetime))
                        
                         'Ende
                        Set LNItem = LNDoc.GETFIRSTITEM("EndDateTime")
                        strEndDateTime = Split(LNItem.Text, ";")
                        datDatetime = CDate(strEndDateTime(i))
                        rsTermine.Fields("Ende_Datum").Value = DateSerial(Year(datDatetime), Month(datDatetime), Day(datDatetime))
                        rsTermine.Fields("Ende_Uhrzeit").Value = TimeSerial(Hour(datDatetime), Minute(datDatetime), Second(datDatetime))
                        
                        'Terminbezeichnung
                        Set LNItem = LNDoc.GETFIRSTITEM("Subject")
                        If LNItem Is Nothing = False Then
                            rsTermine.Fields("Terminbezeichnung").Value = LNItem.Text
                        End If
                        
                        'Termindetails
                        Set LNItem = LNDoc.GETFIRSTITEM("Body")
                        If LNItem Is Nothing = False Then
                            rsTermine.Fields("Termindetails").Value = LNItem.Text
                        End If
                        
                        'Ort
                        Set LNItem = LNDoc.GETFIRSTITEM("Location")
                        If LNItem Is Nothing = False Then
                            rsTermine.Fields("Ort").Value = LNItem.Text
                        End If
                        
                        rsTermine.Update
                    
                    End If
                
                Next
                
                'Ermitteln des nächsten Mail-Dokuments
                Set LNDoc = Collection.GETNEXTDOCUMENT(LNDoc)
                               
                DoEvents
                                
            Loop
        End If
    End If
 
GoTo Ende
 
ErrBeh:
    Set rsFehler = CurrentDb.OpenRecordset("tblFehler", dbOpenTable)
    rsFehler.AddNew
    rsFehler.Fields(0).Value = 0
    rsFehler.Fields(1).Value = Err.Description
    rsFehler.Update
    rsFehler.Close
    Set rsFehler = Nothing
    Err.Clear
    Resume Next
 
Ende:
    Set objNotes = Nothing
    Set LNdb = Nothing
    Set LNView = Nothing
    Set LNItem = Nothing
    Set LNDoc = Nothing
 
 End Function