Sehr große Maildateien haben ihre Größe aufgrund ihrer Anhangs-Dateien. Seit es die deduplizierende Anhangsauslagerung via DAOS gibt, haben die Riesen-Mailboxen auf dem Server ihren Schrecken verloren; die zugehörigen riesigen lokalen Repliken können jedoch nach wie vor problematisch sein, vor allem wenn ihre Größe 60 GB überschreitet. Ein Werkzeug, das das lokale Auslagern von Anhangsdateien gestattet, kann daher in jedem Fall nützlich sein. Dem Anwender muß jedoch klar sein, daß er anschließend selbst für seine Anhangsdateien verantwortlich ist.
Scott T Noebels hat 2010 im "IBM Lotus Notes/Domino 8.5 Forum" einen Agenten publiziert (
http://www-10.lotus.com/ldd/nd85forum.nsf/0/1910c62e9f340824852577cb0056c882?OpenDocument ), auf dem die hier vorgeschlagene Lösung basiert.
Der unten angegebene Lotus-Script-Quelltext (Beginn bei "Option Public") muß in eine Datei (z.B. "Detach_Attachments.lss") gespeichert werden.
Im Notes Designer wird danach auf die Schaltfläche "New Agent" geklickt und der neue Agent z.B. "Anhänge lösen und speichern" genannt. Über "File > Import" wird danach die lss-Datei in den Agenten importiert. Dabei muß bestätigt werden, daß der bestehende (leere) Agenten-Code generell überschrieben werden soll.
Der Agent kann in Ansichten (Alle Dokumente, Gesendet) oder Ordnern über "Aktionen > Anhänge lösen und speichern" aufgerufen werden, nachdem die Mail(s) selektiert wurden, die er bearbeiten soll (jede Mail muß mit einem Häkchen selektiert sein - auch wenn es nur eine ist; Grund: Der Agent darf nicht von einer geöffneten Mail aus gestartet werden). Der Agent fragt nach dem Pfad für die Anhänge (ab dem zweiten Mal wird immer der letzte Pfad direkt vorgeschlagen), löst alle Anhänge in diesen Pfad und ersetzt sie in den Mails durch file:/// - Links auf den jeweiligen Anhang. Für die Links nicht taugliche Dateinamen werden zuvor korrigiert (das vor allem unterscheidet den hier publizierten Code von Scott T Noebels Original). Bereits vorhandene Dateien werden nicht überschrieben; stattdessen erhält der neue Dateiname eine aufsteigende Versionsnummer.
Der Agent wurde nur unter Windows/32 getestet.
Option Public
Option Declare
%INCLUDE "lsconst.lss"
%INCLUDE "lserr.lss"
%REM
These declarations are in support of the MSWindows APIs that are used by this
agent. This means that this agent will only work on Win32 clients.
%END REM
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (Byval hwndOwner As Long, _
Byval nFolder As Long, ppidl As Long) As Long
Const CSIDL_DRIVES = &H11
Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(Byval pidl As Long, Byval pszPath As String) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (Byval pv As Long)
' Returns a file-path in the older DOS 8.3 notation without spaces
Declare Function GetShortPathNameA Lib "kernel32" (Byval lpszLongPath As String,_
Byval lpszShortPath As String, Byval cchBuffer As Long) As Long
%REM
Other global variables
%END REM
Public Const ENV_FOLDER_LOCATION = "DRL_FolderLocation"
Dim objAttachment As NotesEmbeddedObject
Dim rtStyleText As NotesRichTextStyle
Dim rtStyleSep As NotesRichTextStyle
Dim rtStyleLink As NotesRichTextStyle
Dim rtitem As Variant
Dim iCounter As Integer
Dim strExtractName As String
Dim strPath As String
Dim lAnswer As Long
Dim iFilenum As Integer
Dim lBoxTYpe As Long
Dim strMessage As String
Dim strNewLink As String
Dim strNamePart As String
Dim strExtPart As String
Sub Initialize
Dim session As New NotesSession
Dim ws As New NotesUIWorkspace
Dim view As NotesUIView
Dim doc As NotesDocument
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim counter As Integer 'attachment counter
Dim iDocsProcessed As Integer 'processed message counter
Dim dupc As Integer 'duplicated filenames counter
Dim strDetachFolder As String 'receives name of temporary file path
Dim strMessage As String
Dim lBoxType As Long
Dim iErr As Integer
Dim iTaskId As Integer
Dim iTotalAttachments As Integer
Dim iNumDocAttachments As Integer
Dim iTotalDocuments As Integer
Dim iPercentCompleted As Integer
' General errors get trapped here
On Error Goto HandleError
' This on error traps the error that results when the agent attempts to
' open the collection from within a document rather than a view
On Error ErrObjectVariableNotSet Goto NoSelected
' Ensure we are using windows 32... if not then say goodbye.
If Instr(session.Platform, "Windows")=0 Then
strMessage = "Sorry, this only works on a Windows platform at the moment!"
lBoxType = MB_OK+MB_ICONEXCLAMATION
Messagebox strMessage, lBoxType, "Warning"
Exit Sub
End If
' Do some initial stuff to make sure we are in a view and at least
' one document is selected before we go to the trouble of asking
' the user anything
Set db = session.CurrentDatabase
Set view = ws.CurrentView
' This statement will produce an error if the user is currently in a document
' rather than the view.
Set dc = view.Documents
'if no document selected
If dc.Count < 1 Then
strMessage = "You must have selected at least one document before doing this action!"
lBoxType = MB_OK+MB_ICONEXCLAMATION
Messagebox strMessage, lBoxType, "Warning"
Exit Sub
End If
' Get the folder to detach attachments into
If Not fGetDetachFolder(session, strDetachFolder) Then
Exit Sub
End If
iTotalDocuments = dc.Count
iDocsProcessed = 0
Set doc = dc.GetFirstDocument
While Not doc Is Nothing
iDocsProcessed = iDocsProcessed + 1
'detach each attachment
iNumDocAttachments = fDetachRemoveAndLink(session, doc, strDetachFolder)
iTotalAttachments = iTotalAttachments + iNumDocAttachments
iPercentCompleted = Int((iDocsProcessed / iTotalDocuments) * 100)
Print Cstr(iDocsProcessed) & " out of " & Cstr(iTotalDocuments) & _
" (" & Cstr(iPercentCompleted) & "%)"
Set doc = dc.GetNextDocument(doc)
Wend
strMessage = Cstr(iDocsProcessed) & " document(s) processed." & Chr(10) & _
"There were a total of " & Cstr(iTotalAttachments) & Chr(10) & _
"detached into the folder: " & strDetachFolder
lBoxType = MB_OK
Messagebox strMessage, lBoxType, "Finished!"
Call ws.ViewRefresh( )
Exit Sub
HandleError:
iErr = Err()
strMessage = "Please make sure that the folder: " & strDetachFolder & " is available."
lBoxType = MB_OK+MB_ICONSTOP
Messagebox strMessage, lBoxType, "Warning"
Exit Sub
NoSelected:
iErr = Err()
strMessage = "This action must only be taken while in a view!" & _
Chr(13) & "Use the Attachment, Detach All... action while in a document!"
lBoxType = MB_OK+MB_ICONEXCLAMATION
Messagebox strMessage, lBoxType, "Warning"
Exit Sub
End Sub
Function fGetShortPathName(longpath As String) As String
Dim s As String
Dim i As Long
i = Len(longpath) + 1
s = String(i, 0)
GetShortPathNameA longpath, s, i
fGetShortPathName = Left$(s, Instr(s, Chr$(0)) - 1)
End Function
Function fGetFolderLocation() As String
Dim bi As BROWSEINFO ' structure passed to the function
Dim pidl As Long ' PIDL to the user's selection
Dim physpath As String ' string used to temporarily hold the physical path
Dim retval As Long ' return value
Dim vbNullChar As String
vbNullChar = Chr(0)
' Initialize the structure to be passed to the function.
' The owner of the dialog box.
bi.hwndOwner = 0
' Specify the My Computer virtual folder as the root.
retval = SHGetSpecialFolderLocation(0, CSIDL_DRIVES, bi.pidlRoot)
' Make room in the buffer to get the [virtual] folder's display name.
bi.pszDisplayName = Space(260)
' Message displayed to the user.
bi.lpszTitle = "Please choose a folder."
' Nothing else needs to be set.
bi.ulFlags = 0
bi.lpfn = 0
bi.lParam = 0
bi.iImage = 0
' Open the Browse for Folder dialog box.
pidl = SHBrowseForFolder(bi)
' If the user selected something, display its display name
' and its physical location on the system.
If pidl <> 0 Then
'Remove the empty space from the display name variable.
bi.pszDisplayName = Left(bi.pszDisplayName, Instr(bi.pszDisplayName, vbNullChar) - 1)
'Debug.Print "The user selected: "; bi.pszDisplayName
'If the folder is not a virtual folder, display its physical location.
physpath = Space(260)
retval = SHGetPathFromIDList(pidl, physpath)
If retval = 0 Then
'Debug.Print "Physical Location: (virtual folder)"
Else
' Remove the empty space and display the result.
physpath = Left(physpath, Instr(physpath, vbNullChar) - 1)
'Debug.Print "Physical Location: "; physpath
End If
' Free the pidl returned by the function.
CoTaskMemFree pidl
End If
' Whether successful or not, free the PIDL which was used to
' identify the My Computer virtual folder.
CoTaskMemFree bi.pidlRoot
' Return the physpath value
fGetFolderLocation = physpath
End Function
Function fGetDetachFolder(session As NotesSession, strDetachFolder As String) As Variant
On Error Goto HandleError
Dim strMessage As String
Dim lBoxType As Long
Dim lAnswer As Long
fGetDetachFolder = False
'get current saved folder
strDetachFolder = session.GetEnvironmentString( ENV_FOLDER_LOCATION )
'if the folder doesn't exist, show folder location window.
If Isempty(strDetachFolder) Or Len(strDetachFolder) < 2 Then
strDetachFolder = fGetFolderLocation()
If Len(strDetachFolder) < 2 Then
Exit Function
End If
'save strDetachFolder in to .ini
Call session.SetEnvironmentVar( ENV_FOLDER_LOCATION, strDetachFolder )
Else
'check the existance of the current folder, if it doesn't exist, prompt.
If fFileExists(strDetachFolder) Then
strMessage = "Current detach folder: "& strDetachFolder & " doesn't exist"
lBoxType = MB_OK + MB_ICONSTOP
Messagebox strMessage, lBoxType, "Detach Folder"
lAnswer = IDNO
Else
strMessage = "Use current default folder: " & strDetachFolder & "?"
lBoxType = MB_YESNO + MB_ICONQUESTION
lAnswer = Messagebox(strMessage, lBoxType, "Detach Folder")
End If
'if no current default folder, prompt for folder location window.
If lAnswer = IDNO Then
strDetachFolder = fGetFolderLocation()
'if the input string less than 2-character, stop
If Len(strDetachFolder) < 2 Then
Exit Function
End If
'save strDetachFolder in to .ini
Call session.SetEnvironmentVar( ENV_FOLDER_LOCATION, strDetachFolder )
End If
End If
fGetDetachFolder = True
Exit Function
HandleError:
strMessage = "Error in fGetDetachFolder: (" & Err & ") " & Error & " at line: " & Erl
lBoxType = MB_OK + MB_ICONSTOP
Messagebox strMessage, lBoxType, "Error!"
Exit Function
End Function
Function fDetachRemoveAndLinkR5(session As NotesSession, doc As NotesDocument, _
strDetachFolder As String) As Integer
'IN ORDER TO MAKE THIS WORK, REMOVE THE "R5" FROM THE THREE LINES OF CODE THAT EXIST
'WITHIN THIS FUNCTION
On Error Goto HandleError
fDetachRemoveAndLinkR5 = 0
iCounter = 0
' Look for rich text items in the document. Use the first rich text
' item found for rtitem - unless we find one named "Body" which will
' supercede any rich text item found thus far.
' If we don't find a rich text item then quit out of this document
Set rtitem = Nothing
Forall item In doc.Items
If item.Type = RICHTEXT Then
If rtitem Is Nothing Then
Set rtitem = doc.GetFirstItem(item.Name)
Elseif Strcompare(item.Name, "body", 5) = 0 Then
Set rtitem = doc.GetFirstItem(item.Name)
End If
End If
End Forall
' If we have not found a rich text item to use then scream and quit
' this document
If rtitem Is Nothing Then
strMessage = "Unable to locate any rich text items to hold the links " & _
"to the attachments that may be removed. Cannot process this document " & _
"with NoteId of: " & fFormatNoteId(doc.NoteId)
lBoxType = MB_OK+MB_ICONEXCLAMATION
Messagebox strMessage, lBoxType, "No RichText Item Found"
Exit Function
End If
' Iterate through each of the document's items looking for attachments
Forall item In doc.Items
If item.Type = Attachment Then
' Now that we have an attachment, get the embedded object
' associated with it. The first thing in the Values array
' is the name of the attachment.
Set objAttachment = doc.GetAttachment(item.Values(0))
iCounter = iCounter + 1
'get the attachment filename
strExtractName = fvalidatefilename(objAttachment.Name)
'generate a unique path for the file to be detached to - this
'involves checking for the existence of a file with the same name
'and incrementing a counter prepended to the filename until a
'name is found that does not exist in the detach folder.
strPath = strDetachFolder & "\" & strExtractName
iFilenum = 1
While fFileExists(strPath)
strNamePart = Strleftback(strExtractName, ".", 5)
strExtPart = Strrightback(strExtractName, ".", 5)
strPath = strDetachFolder & "\" & strNamePart & "_" & Cstr(iFilenum) & "." & strExtPart
iFilenum = iFilenum + 1
Wend
' Detach the attachment to the unique path
Call objAttachment.ExtractFile(strPath)
' Now create the link to the detached file so that we will
' be able to get to it from this document
' The link will be in the format:
' "Removed Attached file: <attachment> to [file:\\<pathtodetachedfile>]"
' Get the rich text item in which to append the links
'Set rtitem = doc.GetFirstItem("Body" )
' Create the rich text styles
Set rtStyleText = session.CreateRichTextStyle
Set rtStyleSep = session.CreateRichTextStyle
Set rtStyleLink = session.CreateRichTextStyle
' Initialize the styles for the three pieces of each linked file
rtStyleText.Bold = False
rtStyleText.NotesColor = COLOR_DARK_BLUE
rtStyleText.Underline = False
rtStyleText.NotesFont = FONT_HELV
rtStyleText.FontSize = 8
rtStyleSep.Bold = False
rtStyleSep.NotesColor = COLOR_BLACK
rtStyleSep.Underline = False
rtStyleSep.NotesFont = FONT_HELV
rtStyleSep.FontSize = 8
rtStyleLink.Bold = False
rtStyleLink.NotesColor = COLOR_BLUE
rtStyleLink.Underline = True
rtStyleLink.NotesFont = FONT_HELV
rtStyleLink.FontSize = 8
' Build the string to be used in the link
strNewLink = "file:\\" & fGetShortPathName(strPath)
' Append the link to the rich text field
If iCounter = 1 Then
Call rtitem.AddNewLine( 2 )
End If
Call rtitem.AppendStyle( rtStyleText )
Call rtitem.AppendText( "Removed attached file: " & strExtractName & " to " )
Call rtitem.AppendStyle( rtStyleSep )
Call rtitem.AppendText( " --> [ " )
Call rtitem.AppendStyle( rtStyleLink )
Call rtitem.AppendText( strNewLink )
Call rtitem.AppendStyle( rtStyleSep )
Call rtitem.AppendText( " ]" )
Call rtitem.AddNewLine( 1 )
' Remove the attachment from the document
Call objAttachment.Remove
End If
End Forall
' Save the document so that the changes we just made will be retained
Call doc.Save(True, False, True)
fDetachRemoveAndLinkR5 = iCounter
Exit Function
HandleError:
strMessage = "Error in fDetachRemoveAndLink: (" & Err & ") " & Error & " at line: " & Erl
lBoxType = MB_OK + MB_ICONSTOP
Messagebox strMessage, lBoxType, "Error!"
Exit Function
End Function
Function fFileExists(strPath As String) As Variant
fFileExists = Not (Dir(strPath) = "")
End Function
Function fFormatNoteId(strN As String) As String
' Format the NoteId so that it is 8 characters with leading 0's
If Len(strN) = 8 Then
fFormatNoteId = strN
Else
fFormatNoteId = String(8-Len(strN), "0") & strN
End If
End Function
Function fDetachRemoveAndLink(session As NotesSession, doc As NotesDocument, _
strDetachFolder As String) As Integer
On Error Goto HandleError
'Dim objAttachment As NotesEmbeddedObject
Dim rtStyleText As NotesRichTextStyle
Dim rtStyleSep As NotesRichTextStyle
Dim rtStyleLink As NotesRichTextStyle
Dim rtitem As Variant
Dim iCounter As Integer
Dim strExtractName As String
Dim strPath As String
Dim lAnswer As Long
Dim iFilenum As Integer
Dim lBoxTYpe As Long
Dim strMessage As String
Dim strNewLink As String
Dim strNamePart As String
Dim strExtPart As String
fDetachRemoveAndLink = 0
iCounter = 0
' Look for rich text items in the document. Use the first rich text
' item found for rtitem - unless we find one named "Body" which will
' supercede any rich text item found thus far.
' If we don't find a rich text item then quit out of this document
Set rtitem = Nothing
Forall item In doc.Items
If item.Type = RICHTEXT Then
If rtitem Is Nothing Then
Set rtitem = doc.GetFirstItem(item.Name)
Elseif Strcompare(item.Name, "body", 5) = 0 Then
Set rtitem = doc.GetFirstItem(item.Name)
End If
End If
End Forall
' If we have not found a rich text item to use then scream and quit
' this document
If rtitem Is Nothing Then
strMessage = "Unable to locate any rich text items to hold the links " & _
"to the attachments that may be removed. Cannot process this document " & _
"with NoteId of: " & fFormatNoteId(doc.NoteId)
lBoxType = MB_OK+MB_ICONEXCLAMATION
Messagebox strMessage, lBoxType, "No RichText Item Found"
Exit Function
End If
' Iterate through each of the rich text's objects looking for attachments
Forall objAttachment In rtitem.EmbeddedObjects
If objAttachment.Type = EMBED_ATTACHMENT Then
iCounter = iCounter + 1
'get the attachment filename
strExtractName = fvalidatefilename(objAttachment.Name)
'generate a unique path for the file to be detached to - this
'involves checking for the existence of a file with the same name
'and incrementing a counter prepended to the filename until a
'name is found that does not exist in the detach folder.
strPath = strDetachFolder & "\" & strExtractName
iFilenum = 1
While fFileExists(strPath)
strNamePart = Strleftback(strExtractName, ".", 5)
strExtPart = Strrightback(strExtractName, ".", 5)
strPath = strDetachFolder & "\" & strNamePart & "_" & Cstr(iFilenum) & "." & strExtPart
iFilenum = iFilenum + 1
Wend
' Detach the attachment to the unique path
Call objAttachment.ExtractFile(strPath)
Call objAttachment.Remove
' Now create the link to the detached file so that we will
' be able to get to it from this document
' The link will be in the format:
' "Removed Attached file: <attachment> to [file:\\<pathtodetachedfile>]"
' Get the rich text item in which to append the links
'Set rtitem = doc.GetFirstItem("Body" )
' Create the rich text styles
Set rtStyleText = session.CreateRichTextStyle
Set rtStyleSep = session.CreateRichTextStyle
Set rtStyleLink = session.CreateRichTextStyle
' Initialize the styles for the three pieces of each linked file
rtStyleText.Bold = False
rtStyleText.NotesColor = COLOR_DARK_BLUE
rtStyleText.Underline = False
rtStyleText.NotesFont = FONT_HELV
rtStyleText.FontSize = 8
rtStyleSep.Bold = False
rtStyleSep.NotesColor = COLOR_BLACK
rtStyleSep.Underline = False
rtStyleSep.NotesFont = FONT_HELV
rtStyleSep.FontSize = 8
rtStyleLink.Bold = False
rtStyleLink.NotesColor = COLOR_BLUE
rtStyleLink.Underline = True
rtStyleLink.NotesFont = FONT_HELV
rtStyleLink.FontSize = 8
' Build the string to be used in the link
strNewLink = "file:\\" & fGetShortPathName(strPath)
' Append the link to the rich text field
If iCounter = 1 Then
Call rtitem.AddNewLine( 2 )
End If
Call rtitem.AppendStyle( rtStyleText )
Call rtitem.AppendText( "Removed attached file: " & strExtractName & " to " )
Call rtitem.AppendStyle( rtStyleSep )
Call rtitem.AppendText( " --> [ " )
Call rtitem.AppendStyle( rtStyleLink )
Call rtitem.AppendText( strNewLink )
Call rtitem.AppendStyle( rtStyleSep )
Call rtitem.AppendText( " ]" )
Call rtitem.AddNewLine( 1 )
End If
End Forall
' Save the document so that the changes we just made will be retained
Call doc.Save(True, False, True)
fDetachRemoveAndLink = iCounter
Exit Function
HandleError:
strMessage = "Error in fDetachRemoveAndLink: (" & Err & ") " & Error & " at line: " & Erl
lBoxType = MB_OK + MB_ICONSTOP
Messagebox strMessage, lBoxType, "Error!"
Exit Function
End Function
Function fvalidatefilename(filename As String)
Dim l As Integer
Dim x As Integer
Dim newname As String
l=Len(filename)
For x = 1 To l
If Mid$(filename,x,1) Like "[-.@()~^$#[{}=A-Za-z0-9]" Then
newname=newname+Mid$(filename,x,1)
Else
If Mid$(filename,x,1)="]" Or Mid$(filename,x,1)="," Or Mid$(filename,x,1)="'" Or Mid$(filename,x,1)="!" Then
newname=newname+Mid$(filename,x,1)
Else
newname=newname+"-"
' Print Mid$(filename,x,1) " is not valid"
End If
End If
Next x
fvalidatefilename=newname
End Function
Thema: Agent zum Lösen/Entfernen von Anhängen und Ersatz des Anhangs durch einen Link (Gelesen 6741 mal)