Habe dies in meiner Sammlung von Notes Zaubersprüchen und Beschwörungen gefunden
The following script detaches all file attachments from all mail messages saving them into C:/ReceivedFiles, C:/SentFiles or C:/OtherFiles depending in their original location (received/sent messages or calendar entries). Users can decide whether to remove detached files or leave them in the mail file. Multiple files with the same file name are renamed by adding a "c_" in front of the original file name.
Dim sess As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim FilePresent As String
Dim FileName As String
Dim sDir As String
Dim i As Integer
Dim path As String
i = Msgbox ("YES = Detach AND Remove" & Chr(13) & Chr(13) & "NO = Detach but don't remove" & Chr(13) & _
Chr(13) & "CANCEL = I was joking, do nothing!",35,"Remove attachments?") 'Ask whether remove attachments or not
'If user chooses CANCEL then exit program
If i = 2 Then
Exit Sub
End If
'Check for the presence of destination folders and creates them if missing;
sDir = Dir$("C:/ReceivedFiles",16)
If sDir = "" Then
Mkdir "C:/ReceivedFiles"
End If
sDir = Dir$("C:/SentFiles",16)
If sDir = "" Then
Mkdir "C:/SentFiles"
End If
sDir = Dir$("C:/OtherFiles",16)
If sDir = "" Then
Mkdir "C:/OtherFiles"
End If
'---------------------------------------------------------
Set db = sess.CurrentDatabase
Set view = db.GetView("($All)")
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
If doc.HasEmbedded Then 'Checks for presence of embedded objects
If doc.HasItem("DeliveredDate") Then
path = "C:/ReceivedFiles"
Else
If doc.HasItem("POSTEDDATE") Then
path = "C:/SentFiles"
Else
path = "C:/OtherFiles"
End If
End If
Set rtitem = doc.GetFirstItem("Body")
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
FileName = o.Source
FilePresent = Dir$(path & FileName,0)
'If current filename is already present in the directory then renames the destination file and checks again
If FilePresent <> "" Then
Do Until FilePresent = ""
FileName = "c_ " & FileName
FilePresent = Dir$(path & FileName,0)
Loop
End If
Call o.ExtractFile(path & FileName )
Print "Extracting " & o.Source
'If user pressed YES in the initial msgbox then removes attachments
If i = 6 Then
Call o.Remove
Call doc.Save( False, True )
End If
End If
End Forall
End If
Set doc = view.GetNextDocument(doc)
Loop