OK,
gerne. :-)
Erstmal gibt es einen Archivierungs-Agent, der über das Pull-Down-Menu zu starten ist. Er wird einfach in der Mail-DB bzw. Template als Agent gespeichert.
Option Public
Option Declare
Dim strFolder As String
Sub Initialize
'Archivierung von Dateianhängen...
On Error Goto debug
Dim session As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim coll As notesdocumentCollection
Dim rtitem As Variant
Dim searchformula As String
Dim intCheck As Integer
Dim boolIsMime As Boolean
Dim richStyle As NotesRichTextStyle
Set richStyle = session.CreateRichTextStyle
Dim arAttachmentNames() As String
Dim counter As Integer
Dim boolChange As Boolean
Dim aNames As Variant
Dim objFile As NotesEmbeddedObject
'Mime-Body ##
Dim strText As String
Dim child As NotesMIMEEntity
Dim stream As NotesStream
Dim mimeBody As NotesMIMEEntity
'############
Set db=session.currentdatabase
'Set coll = db.UnprocessedDocuments
searchformula = {(Form = "Memo" | Form = "memo" | Form = "Reply" | Form = "reply" | Form = "NonDelivery Report") & @Attachments <> 0 & ((@Now - @Created) / 86400) > 90}
Set coll=db.Search(searchformula,Nothing,0)
If coll.Count =0 Then
Messagebox "Keine Dokumente mit Anhängen gefunden, die älter als 90 Tage sind."
Exit Sub
End If
intCheck = Messagebox ("Sollen alle Anhänge aus allen " + Cstr(coll.Count) + " Mails, die älter als 90 Tage sind, archiviert werden?" + Chr(13) + Chr(13) + "Bitte voher eine Datensicherung durchführen!",49,"Anhänge archivieren...")
If intCheck <> 1 Then
Exit Sub
End If
'Grundverzeichnis erstellen
If isFolder({z:\mail\} + Strleft(db.FileName,".nsf")) = False Then
Mkdir {z:\mail\} + Strleft(db.FileName,".nsf")
End If
Set doc = coll.GetFirstDocument
Do Until doc Is Nothing
counter = 0
boolChange = False
Erase arAttachmentNames
strFolder = getDateFolder(doc,{z:\mail\} + Strleft(db.FileName,".nsf"))
'#########################
' Detach the Attachments MIME
If doc.getitemvalue("$NoteHasNativeMIME")(0) = "1" Then
'##################################################
'bei mime-Mails wird anders vorgegangen
aNames = Evaluate({@AttachmentNames}, doc)
boolIsMime = True
If aNames(0) <> "" Then
Forall attname In aNames
Redim Preserve arAttachmentNames(counter)
boolChange = True
If Not Isnull(Arraygetindex(arAttachmentNames, strFolder & {\} & attName )) Then
'eindeutige Namen generieren, falls notwendig...
arAttachmentNames(counter) = {} & strFolder & {\Att_} & Cstr(counter) & {_} & attName
Else
arAttachmentNames(counter) = {} & strFolder & {\} & attName
End If
Set objFile = doc.GetAttachment(attname)
Call objFile.ExtractFile(arAttachmentNames(counter))
'Messagebox arAttachmentNames(counter)
Call objFile.Remove
counter = counter + 1
End Forall
End If
Else
'#################################################
'keine Mime-Mail (normal)
boolIsMime = False
Set rtitem = doc.GetFirstItem( "Body")
If ( rtitem.Type = RICHTEXT ) And Not Isempty(rtitem.EmbeddedObjects) Then
'zunächst alle Attachments suchen...
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Redim Preserve arAttachmentNames(counter)
boolChange = True
If Not Isnull(Arraygetindex(arAttachmentNames, strFolder & {\} & o.Source )) Then
'eindeutige Namen generieren, falls notwendig...
arAttachmentNames(counter) = {} & strFolder & {\Att_} & Cstr(counter) & {_} & o.Source
Else
arAttachmentNames(counter) = {} & strFolder & {\} & o.Source
End If
Call o.ExtractFile( arAttachmentNames(counter))
Call o.Remove
counter = counter + 1
End If
End Forall
End If
End If
'#################################################
Set rtitem = doc.GetFirstItem( "Body")
'jetzt Text anhängen
If boolChange = True Then
'Falls am Ende der Mail
If ( rtitem.Type = RICHTEXT ) Then
'RICHTEXT ############################
richStyle.Bold = False
richStyle.NotesColor = COLOR_BLACK
richStyle.FontSize = 10
Call rtItem.AppendStyle(richStyle)
Call rtItem.AddnewLine(2)
Call rtItem.AppendText("########## Datei Info Start ##########")
Call rtItem.AddnewLine(2)
If Ubound(arAttachmentNames) = 0 Then
Call rtItem.AppendText( Cstr(Ubound(arAttachmentNames) + 1) + " Dateianhang wurde archiviert:" )
Else
Call rtItem.AppendText( Cstr(Ubound(arAttachmentNames) + 1) + " Dateianhänge wurden archiviert:" )
End If
Call rtItem.AddnewLine(2)
Forall entry In arAttachmentNames
Call rtItem.AppendText( entry )
Call rtItem.AddnewLine(1)
End Forall
Call rtItem.AddnewLine(1)
Call rtItem.AppendText("#####Folder~" + strFolder + "~#####")
Call rtItem.AddnewLine(2)
Call rtItem.AppendText("########## Datei Info Ende ##########")
Else
'MIME ################################
' REM Create child entity
Set mimeBody = rtitem.getMimeEntity
Set stream = session.CreateStream
Set child = mimeBody.CreateChildEntity
strText = Chr(13) + Chr(10)
strText = strText + "########## Datei Info Start ##########" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
If Ubound(arAttachmentNames) = 0 Then
strText = strText + Cstr(Ubound(arAttachmentNames) + 1) + " Dateianhang wurde archiviert:" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
Else
strText = strText + Cstr(Ubound(arAttachmentNames) + 1) + " Dateianhänge wurden archiviert:" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
End If
Forall entry In arAttachmentNames
strText = strText + entry + Chr(13) + Chr(10)
End Forall
strText = strText + Chr(13) + Chr(10)
strText = strText + "#####Folder~" + strFolder + "~#####" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
strText = strText + "########## Datei Info Ende ##########"
Call stream.WriteText(strText)
Call child.SetContentFromText(stream, "text/plain", ENC_NONE)
Call stream.Truncate
End If
Call doc.ReplaceItemValue("_ViewIcon2",50)
Call doc.Save(True,True)
End If
forgetit:
Set doc = coll.GetNextDocument(doc)
Loop
Exit Sub
debug:
Print "Initialize: " + Cstr(Err) + " at line " + Cstr(Erl) + ": " + Error$
If Not doc Is Nothing Then
Print "Initialize: " + doc.Subject(0) + " " + Cstr(doc.Created)
Resume forgetit
Else
Resume finished
End If
finished:
End Sub
Function getDateFolder(doc As NotesDocument, strFolder As String) As String
On Error Goto debug
Dim strDateFolder As String
Dim strTimeFolder As String
Dim strDir As String
Dim i As Integer
'@If(DeliveredDate != ""; DeliveredDate; PostedDate != ""; PostedDate; @Created)
Dim dateMail As New NotesDateTime("")
If doc.DeliveredDate(0) <> "" And Isdate(doc.DeliveredDate(0)) Then
dateMail.LocalTime = doc.getItemValue("DeliveredDate")(0)
Elseif doc.PostedDate(0) <> "" And Isdate(doc.PostedDate(0)) Then
dateMail.LocalTime = doc.getItemValue("PostedDate")(0)
Else
dateMail.LocalTime = Cstr(doc.Created)
End If
strDateFolder = Cstr(Year(dateMail.LsLocalTime)) + {-} + Right$("0" + Cstr(Month(dateMail.LsLocalTime)),2) + {-} + Right$("0" + Cstr(Day(dateMail.LsLocalTime)),2)
If isFolder(strFolder + {\} + strDateFolder) = False Then
Mkdir strFolder + {\} + strDateFolder
End If
strTimeFolder = Right$("0" + Cstr(Hour(dateMail.LsLocalTime)),2) + {-} + Right$("0" + Cstr(Minute(dateMail.LsLocalTime)),2)
'##############################################
If isFolder(strFolder + {\} + strDateFolder + {\} + strTimeFolder) = True Then
strDir = Dir$(strFolder + {\} + strDateFolder + {\} + strTimeFolder +{\*.*},0)
Else
Mkdir strFolder + {\} + strDateFolder + {\} + strTimeFolder
End If
If isFolder(strFolder + {\} + strDateFolder + {\} + strTimeFolder) = True And strDir <> "" Then
'Dieser muss eindeutig sein! Schleife läuft, wenn es einen Ordner gibt, der nicht leer ist
For i=1 To 1000
If isFolder(strFolder + {\} + strDateFolder + {\} + strTimeFolder + {_} + Cstr(i)) = False Then
'Erster Fall: den Ordner gibt es noch nicht
strTimeFolder = strTimeFolder + {_} + Cstr(i)
Mkdir strFolder + {\} + strDateFolder + {\} + strTimeFolder
Exit For
Elseif isFolder(strFolder + {\} + strDateFolder + {\} + strTimeFolder + {_} + Cstr(i)) = True And Dir$(strFolder + {\} + strDateFolder + {\} + strTimeFolder + {_} + Cstr(i) + {\*.*},0) = "" Then
'Zweiter Fall: Es gibt den Ordner, er ist aber leer
strTimeFolder = strTimeFolder + {_} + Cstr(i)
Exit For
End If
Next
End If
'##############################################
'Messagebox strFolder + {\} + strDateFolder + {\} + strTimeFolder
getDateFolder = strFolder + {\} + strDateFolder + {\} + strTimeFolder
Exit Function
debug:
Print "getDateFolder: " + Cstr(Err) + " at line " + Cstr(Erl) + ": " + Error$
Resume finished
finished:
End Function
Function isFolder(sFolderPath As String) As Boolean
On Error Goto debug
On Error 76 Resume Next
Const ATTR_DIRECTORY = 16
isFolder = False
If Dir$(sFolderPath, ATTR_DIRECTORY) <> "" Then isFolder = True
Exit Function
debug:
Print "isFolder: " + Cstr(Err) + " at line " + Cstr(Erl) + ": " + Error$
Resume finished
finished:
End Function
In dem Agent ist das Laufwerk "Z" einfach fest vorgegeben, dies muss natürlich existieren. In diesem gibt es dann den Ordner "mail" und wiederum in diesem dann für jede Mail-DB einen weiteren Ordner, der so heisst wie der Dateiname der Datenbank. Pro Mail werden hier maximal 1000 Anhänge berücksichtigt.
Wie Ihr seht, wird bei jedem Doc, das angefasst wird, das Feld "_ViewIcon2" auf 50 gesetzt. Dadurch erscheint bei in jeder Ansicht anstatt dem Büroklammer-Symbol (Attachment vorhanden) ein Disketten-Symbol (Archiviert).
Dann gibt es eine Shared Action, die dann einfach als Button in der Maske "Memo" angefügt wird. Die Aktion bezieht den Ordner-Namen aus dem, was zuvor der Archivierungs-Agent im Mail-Body hinterlegt hat. Dieser Ordner wird dann als (Windows-) Fenster geöffnet.
Der Button ist verborgen wenn nichts hinterlegt ist, also (verbergen-wenn Formel):
_text := @Abstract([TextOnly];15360;"";"Body");
_text := @Right(_text;"#####Folder~");
_text := @Left(_text;"~#####");
_text=""
Code des Buttons:
Sub Click(Source As Button)
'##########################################
'Dieser Agent holt den freigegebenen Ordner, in
'dem die Anhänge archiviert wurden und öffnet ihn
'mit dem Windows-Explorer
'##########################################
On Error Goto debug
Dim ws As New notesuiworkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim strText As String
Dim rtitem As Variant
Set uidoc = ws.CurrentDocument
Set doc = uidoc.Document
Set rtitem = doc.GetFirstItem( "Body" )
strText = rtitem.getUnformattedText()
strText = Strright(strText,{#####Folder~})
strText = Strleft(strText,{~#####})
If strText ="" Then
Messagebox "Kein archivierter Anhang gefunden!"
Else
result = Shell ({explorer.exe } + strText + {},1)
If result <> 33 Then
Messagebox "Konnte den Windows Explorer nicht öffnen!"
Exit Sub
End If
End If
Exit Sub
debug:
Messagebox Cstr(Err) + " at line " + Cstr(Erl) + ": " + Error$
Resume finished
finished:
End Sub
Mit dieser Methode haben wir sehr gute Erfahrungen machen können. Wir halten damit fast alle Mail-Datenbanken unter 4GB. Alle paar Wochen mache ich zunächst ein Backup und archiviere dann mit diesem Agenten. Sicher geht das auch im Backend, das habe ich aber aus Sicherheitsgründen so nicht gemacht, denn so kann man eben sicher gehen, dass ein Backup unmittelbar davor angelegt wurde.
Das wars schon - ich freue mich natürlich über Anregungen und Verbesserungsvorschläge jeglicher Art.
Gruß, Bernd