Hallo,
wir hatten die gleiche Anforderung und haben dies über einen wöchentlichen Agenten in der Mail-Db gelöst.
Hier der entsprechende Codeteil:
Private Sub ClearInbox()
%REM
Beschreibung:
Dieses Script resduziert den Inhalt des Ordners "Eingang | ($Inbox)" auf eine maximale Anzahl von Dokumenten
Darüberhianus gehende Dokumente werden in einen normalen Ordner "- Ausgelagerter Eingang -" verschoben.
Es verbleiben die aktuellsten Dokumente.
%END REM
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim ecol As NotesViewEntryCollection
Dim entry As NotesViewEntry
Dim doc As NotesDocument
Dim Auslagerungsordner As String
Dim wert As String
Dim array() As String
Dim vList As Variant
Dim i As Long
Dim sErrorMess As String
On Error Goto Fehler
Const MaxInboxEntries = 250
Set db = session.CurrentDatabase
Auslagerungsordner = "- Ausgelagerter Eingang -"
Set view = db.GetView("($Inbox)")
If view Is Nothing Then Goto Ende
view.AutoUpdate = False
Set ecol = view.AllEntries
If ecol.Count > MaxInboxEntries Then
' Eingang zu groß
Redim array(MaxInboxEntries) As String
i = 0
Set entry = ecol.GetFirstEntry
Do While Not entry Is Nothing
Set doc = entry.Document
If Cstr(doc.DeliveredDate(0)) <> "" Then
wert = Format(doc.DeliveredDate(0), "yyyymmdd") + Format(doc.DeliveredDate(0), "hhmmss")
Elseif Cstr(doc.PostedDate(0)) <> "" Then
wert = Format(doc.PostedDate(0), "yyyymmdd") + Format(doc.PostedDate(0), "hhmmss")
Else
wert = Format(doc.Created, "yyyymmdd") + Format(doc.Created, "hhmmss")
End If
wert = wert + "~" + doc.UniversalID
If i > Ubound(array) Then Redim Preserve array(Ubound(array) + 100) As String
array( i ) = wert
i = i + 1
Set entry = ecol.GetNextEntry(entry)
Loop
vList = Fulltrim(array)
' nach Datum absteigend sortieren
Call ArraySort( vList, True)
For i = MaxInboxEntries To Ubound(vList)
Set doc = db.GetDocumentByUNID(Strright(vList( i ), "~"))
Call doc.PutInFolder(Auslagerungsordner, True)
Call doc.RemoveFromFolder("($Inbox)")
Next
End If
Ende:
Set doc = Nothing
Set entry = Nothing
Set ecol = Nothing
Set view = Nothing
Set db = Nothing
Exit Sub
Fehler:
Msgbox "Fehler bei der Bereinigung des Eingangs: " + Error$ + " in Zeile " + Str(Erl), 16, "Fehler"
Resume Ende
End Sub
Private Sub ArraySort( array As Variant, descending As Integer)
%REM
Parameter:
array (Input) - Zu sortierende Daten
descending (Input) - Absteigent sortieren = True, Aufsteigend = False
Beschreibung: Sortiert ein array von Werten unter Nutzung des Shell Sort Algorithmus (Portiert aus C)
%END REM
Dim aSpans(1 To 9) As Integer
Dim nSpanCount As Integer
Dim nSpanIncr As Integer
Dim nLimit As Integer ' Die Anzahl der zu sortierenden Werte
Dim nSpan As Integer
Dim KeyNum As Integer
Dim SwapEm As Integer
Dim SubArray(1 To 3) As Variant
Dim Record1Keys As Variant
Dim Record2Keys As Variant
Dim doc As notesDocument
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Temp As Variant
Dim floor As Integer
' Definition der spans welche vom Algorithmus genutzt werden
aSpans(1) = 9840
aSpans(2) = 3279
aSpans(3) = 1093
aSpans(4) = 364
aSpans(5) = 121
aSpans(6) = 40
aSpans(7) = 13
aSpans(8) = 4
aSpans(9) = 1
' Die maximale Anzahl von spans
nSpanCount = 9
' Womit soll gestartet werden ?
nSpanIncr = 1
floor = Lbound( array )
nLimit = Ubound( array ) - floor
If nLimit = 1 Then Exit Sub ' Ein einzelnes Element muss nicht sortiert werden
j = floor
For k = nSpanCount To 1 Step -1
If aSpans(k) > nLimit Then
Exit For
End If
j = k
Next
i = j
For i = j To nSpanCount
nSpan = aSpans(i )
For j = nSpan To nLimit
Temp = array(j)
k = j - nSpan
Do While k >= floor
Dim doSwap As Integer
If descending Then
doSwap = Temp > array(k)
Else
doSwap = Temp < array(k)
End If
If doSwap Then
array(k + nSpan) = array(k)
k = k - nSpan
Else
Exit Do
End If
Loop
array( k + nSpan ) = Temp
Next j
Next i
End Sub
Der erste Lauf ist vom Zeitverhalten etwas problematisch, aber dann danken es die Server.
Gruß
André