| 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 |