Problem erledigt
Angehängter Code kann einfach als Button per eMail verschickt werden und exportiert alle Kalendereinträge der nächsten drei Monate
__________________
Hier ein Update. Der alte Code hatte Probleme mit Kalendereinträgen die ausserhalb von Notes erstellt wurden (z.B. mit dem PALM). Das ist nun bereinigt.
__________________
Aller guten Dinge sind Drei. Anbei die Version die auf jedem Notes Client und mit jedem externen Gerät, welches den Notes Kalender synct, laufen sollte!
__________________
Sub Click(Source As Button)
Dim s As New NotesSession
Dim db As NotesDatabase
Dim pnab As New NotesDatabase( "", "names.nsf" )
Dim dcoll As NotesDocumentCollection
Dim doc As NotesDocument
Dim datadir As String
Dim FileHandle As Integer
Dim FileName As String
Dim FileNameTime As String
On Error Goto errorhandler
'Teil I - bestimmen von Speicherort und -namen, erzeugen der CSV-Datei
Set db = s.CurrentDatabase
datadir = Strleftback ( pnab.filepath , "\" , 0 )
If Hour( Time ) < 10 Then
FileNameTime = "0" & Hour( Time )
Else
FileNameTime = Hour( Time )
End If
If Minute( Time ) < 10 Then
FileNameTime = FileNameTime & "-0" & Minute( Time )
Else
FileNameTime = FileNameTime & "-" & Minute( Time )
End If
If Second( Time ) < 10 Then
FileNameTime = FileNameTime & "-0" & Second( Time )
Else
FileNameTime = FileNameTime & "-" & Second( Time )
End If
FileName = datadir & "\" & Strrightback( s.CommonUserName , " " , 0 ) & "_" & Strleftback ( s.CommonUserName , " " , 0 ) & "_" & Cstr( Today ) & "_" & FileNameTime & ".csv"
FileHandle = Freefile()
Open FileName For Output As FileHandle
Print #FileHandle, "StartTermin" & ";StartZeit" & ";EndTermin" & ";EndZeit" & ";Ganztägiges Ereignis"
'Teil II - normale Kalendereinträge für den Export suchen
Print "Dokumente werden gesucht - bitte warten...!"
Dim searchFormula As String
searchFormula$ = { Form = "Appointment" & !@IsResponseDoc }
Set dcoll = db.Search( searchFormula$, Nothing , 0 )
Set doc = dcoll.GetFirstDocument
Print "Zu exportierende Dokumente wurden gefunden, beginne Export..."
Dim actualDate As New NotesDateTime( Now )
Dim startDate As New NotesDateTime( "" )
Dim endDate As New NotesDateTime( "" )
While Not doc Is Nothing
If doc.Responses.Count = 0 Then 'And Not doc.IsResponse Then
Select Case doc.AppointmentType(0)
Case "0", "3" 'Dokument hat einen Start- und Endtermin
Set startDate = New NotesDateTime( doc.StartDateTime(0) )
Set endDate = New NotesDateTime( doc.EndDateTime(0) )
If endDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";" & startDate.TimeOnly & ";" & endDate.DateOnly & ";" & endDate.TimeOnly & ";nein"
End If
Case "4" 'Dokument ist eine Erinnerung ohne Endtermin --> als Endtermin wird der Starttermin gesetzt
Set startDate = New NotesDateTime( doc.StartDateTime(0) )
If startDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";" & startDate.TimeOnly & ";" & startDate.DateOnly & ";" & startDate.TimeOnly & ";nein"
End If
Case "1", "2" 'Jahrestage und Veranstaltungen ohne Endtermin (Zeit)
Set startDate = New NotesDateTime( doc.StartDateTime(0) )
Set endDate = New NotesDateTime( doc.EndDateTime(0) )
If endDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";00:00:00;" & endDate.DateOnly & ";23:59:59" & ";ja"
End If
End Select
End If
Set doc = dcoll.GetNextDocument( doc )
Wend
'Teil III - wiederholende Kalendereinträge für den Export suchen
searchFormula$ = { Form = "Appointment" & @IsResponseDoc }
Set dcoll = db.Search( searchFormula$, Nothing , 0 )
Set doc = dcoll.GetFirstDocument
While Not doc Is Nothing
Select Case doc.AppointmentType(0)
Case "1" 'sich wiederholender Jahrestag
Forall x In doc.CalendarDateTime
Set startDate = New NotesDateTime( x )
If startDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";00:00:00;" & startDate.DateOnly & ";23:59:59" & ";ja"
End If
End Forall
Case "2" 'sich wiederholende Veranstaltung ohne Endtermin (Zeit)
Set startDate = New NotesDateTime( doc.StartDateTime(0) )
Set endDate = New NotesDateTime( doc.EndDateTime(0) )
If endDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";00:00:00;" & endDate.DateOnly & ";23:59:59" & ";ja"
End If
Case "4" 'sich wiedeholende Erinnerungen
Forall x In doc.CalendarDateTime
Set startDate = New NotesDateTime( x )
Set startTime = New NotesDateTime( x )
If startDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";" & startTime.TimeOnly & ";" & startDate.DateOnly & ";" & startTime.TimeOnly & ";nein"
End If
End Forall
Case "0", "3" 'sich wiederholende Besprechung
Set endDate = New NotesDateTime( doc.EndDateTime(0) )
Forall x In doc.CalendarDateTime
Set startDate = New NotesDateTime( x )
If startDate.TimeDifferenceDouble( actualDate ) > 0 And startDate.TimeDifferenceDouble( actualDate ) < 7776000 Then
Print #FileHandle, startDate.DateOnly & ";" & startDate.TimeOnly & ";" & startDate.DateOnly & ";" & endDate.TimeOnly & ";nein"
End If
End Forall
End Select
Set doc = dcoll.GetNextDocument( doc )
Wend
Close FileHandle
'Teil IV - Datei per eMail verschicken und löschen
Dim maildoc As New NotesDocument( db )
Dim ritem As New NotesRichTextItem( maildoc , "Body" )
Dim object As NotesEmbeddedObject
maildoc.Form = "Memo"
maildoc.sendto = s.UserName
maildoc.subject = "Kalenderexport vom " & Now
Set object = ritem.EmbedObject( Embed_Attachment , "" , FileName )
Call maildoc.Send( False )
Kill FileName
Msgbox "Ihre Kalenderdaten wurden erfolgreich exportiert!" , 64 , "Export abgeschlossen"
Print "Export erfolgreich abgeschlossen!"
Goto Ende
ErrorHandler:
Print "Zeile: " & Erl & " Error: " & Error & " Fehlernummer: " & Err
Resume Ende
Ende:
End Sub
_________________________________
Für den Fall, dass ich jemandem damit ein gutes Stück Arbeit abnehmen konnte... :-)
