Kalendereinträge automatisiert löschen

Sub Initialize
	Dim s As New NotesSession
	Dim db As NotesDatabase	
	Dim dc As NotesDocumentCollection	
	Dim doc As NotesDocument	
	Dim dcNotice As NotesDocumentCollection
	Dim docNotice As NotesDocument
	Dim holdoc As notesdocument

	Dim nextdoc As Notesdocument
	Dim tmpdt As New NotesDateTime("")
	Dim purgedate As  New NotesDateTime	("Today")
	Dim n As Integer	
	Dim StartDate As Variant
	Dim OkToPurge As Integer

	Dim profile As NotesDocument	
	Dim nextProfDoc As NotesDocument
	Dim ProfileDoc As NotesDocument

	Set db=s.CurrentDatabase
	Set dc=db.UnprocessedSearch("@Contains(Form;""Reservation"")", tmpdt,0)
	Set dcNotice=db.UnprocessedSearch("@Contains(Form;""Notice"")", tmpdt,0)

	' to remove all docs with form="Notice" from db
	Set docNotice = dcNotice.GetFirstDocument
	For j=1 To dcNotice.count
		Set holddoc=dcNotice.GetNextdocument(docNotice)
		If Not(docNotice Is Nothing)  Then docNotice.Remove (True)
		Set docNotice = holddoc
	Next

	' to remove all profile docs with no "$Busyname"
	Set dcProf= db.GetProfileDocCollection("CalendarProfile")

	Set ProfileDoc = dcProf.GetFirstDocument
	For i=1 To dcProf.count
		Set nextProfDoc=dcProf.GetNextdocument(ProfileDoc)
		If Not(ProfileDoc.HasItem("$BusyName"))  Then ProfileDoc.Remove (True)
		Set ProfileDoc = nextProfDoc
	Next

	Call purgedate.AdjustDay (-14)
	Set doc=dc.GetFirstDocument


	While	Not (doc Is Nothing) 

		If doc.HasItem("$NoPurge")  And Not(Isempty(doc.GetItemValue("$NoPurge")(0))) Then
			Dim tmpNoPurge As New NotesDateTime(doc.GetItemValue("$NoPurge")(0))

			If tmpNoPurge.IsValidDate And tmpNoPurge.DateOnly <>"" Then 
				StartDate=doc.GetitemValue("$NoPurge")				
			Else
				StartDate=doc.GetitemValue("StartDateTime")	
			End If
		Else
			StartDate=doc.GetitemValue("StartDateTime")	
		End If

		Forall eachstartdate In StartDate
			Dim tmpstartdate As New NotesDateTime(eachstartdate)
			If tmpstartdate.IsValidDate Then 
				If purgedate.TimeDifference(tmpstartdate)>0 Then

					OkToPurge=True
				Else

					OkToPurge=False	
					Goto DoNextDocument
				End If
			Else
				Goto donextdocument
			End If 


		End Forall

		If OkToPurge Then	
			Set nextdoc=dc.GetNextDocument (doc)				
			doc.Remove (True)
		Else
			Call s.UpdateprocessedDoc(doc)
		End If		

DoNextDocument:		
		If doc Is Nothing Then
			Set doc=nextdoc			
		Else
			Set doc=dc.GetNextDocument (doc)		
		End If			
	Wend	


End Sub