(Options) - Section
Option Public
Use "libWord"
Use "FileLibrary"
Initialize - Section
Sub Initialize
Dim workspace As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim clsWord As cWord
Dim intTitel As Integer
Dim idx As Integer
Dim intAbbruch As Integer
Dim varName As Variant
Dim varResult As Variant
Dim cFile As CFile
Dim strMacro As String
Dim strFileName As String
Dim arrFiles() As String
Const ATTR_READONLY = 1
intAbbruch = 0
Redim arrFiles(0)
On Error Goto ErrorHandling
Set uidoc = workspace.CurrentDocument
Set doc = uidoc.Document
'Extrahieren des allgemeinen Namens aus dem Mail-Absender
strMacro = | @Name([CN]; DisplayFrom)|
varName = Evaluate(strMacro, doc)
'Messagebox varName(0)
'Wenn im allgm. Namen " enthalten sind, werden sie entfernt
If Instr(varName(0), Chr$(34)) > 0 Then
strMacro = | @ReplaceSubstring(| & varName(0) & |; @Char(34); "")|
varName = Evaluate(strMacro,doc)
'Messagebox varName(0)
End If 'If Instr(varName(0), Chr$(34)) > 0 Then
'Austausch der : in . bei Uhrzeit
strMacro = | @ReplaceSubstring("| & doc.DisplayDate(0) & |"; ":"; ".")|
varResult = Evaluate(strMacro)
'Austausch des Leerzeichens in _
strMacro = | @ReplaceSubstring("| & varResult(0) & |"; " "; "_")|
varResult = Evaluate(strMacro)
'Abfrage des Verzeichnisses und des Dateinamens
Set cFile = New cFile
cFile.DefaultDir = ""
cFile.DefaultFilename = varName(0) & " " & varResult(0) 'Vorgabedateiname ist der allg. Name des Senders und Empfangsdatum
cFile.Title = "Mail-Export"
cFile.Filter = "Word-Dokument (*.doc)" & Chr$(0) & "*.doc" & Chr$(0) & "Alle Dateien (*.*)" & Chr$(0) & "*.*" & Chr$(0)
cFile.FilterIndex = 1
result = cFile.FileSaveDlg
If result = 0 Then
Messagebox "Der Export wurde abgegrochen.", 64, "Mail-Export"
Exit Sub
End If 'If result = 0 Then
While Dir$(cFile.Filename, 0) <> ""
Messagebox "Der angegebene Dateiname ist bereits vorhanden." & Chr$(10) & "Bitte geben Sie einen anderen Dateinamen ein.", 48, "Mail-Export"
result = cFile.FileSaveDlg
If result = 0 Then
Messagebox "Der Export wurde abgegrochen.", 64, "Mail-Export"
Exit Sub
End If 'If result = 0 Then
Wend 'While Dir$(cFile.Filename, 0) <> ""
'Neue Instanz der Klasse cWord
Set clsWord = New cWord
'Neues Dokument auf Basis der Vorlage erstellen
Call clsWord.CreateNewDoc("Normal")
'Formatiertes Einfügen der Mail-Header Infos
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
Call clsWord.Insert("Mail von: ")
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
Call clsWord.Insert(doc.DisplayFrom(0))
Call clsWord.Newline(1)
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
If Isdate(doc.DeliveredDate(0)) Then
Call clsWord.Insert("Mail eingegangen am: ")
Else
Call clsWord.Insert("Mail gesendet am: ")
End If 'If Isdate(doc.DeliveredDate(0)) Then
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
Call clsWord.Insert(Cstr(doc.DisplayDate(0)))
Call clsWord.Newline(2)
Call clsWord.SetTab(2.5)
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
Call clsWord.Insert("An: ")
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
strMacro = | @Name([Abbreviate]; SendTo)|
varName = Evaluate(strMacro, doc)
For idx = 0 To Ubound(varName)
Call clsWord.Insert(Chr$(9) & varName(idx))
Call clsWord.Newline(1)
Next 'For idx = 0 To Ubound(varName)
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
Call clsWord.Insert("Kopie: ")
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
strMacro = | @Name([Abbreviate]; CopyTo)|
varName = Evaluate(strMacro, doc)
For idx = 0 To Ubound(varName)
Call clsWord.Insert(Chr$(9) & varName(idx))
Call clsWord.Newline(1)
Next 'For idx = 0 To Ubound(varName)
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
Call clsWord.Insert("Bindkopie: ")
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
strMacro = | @Name([Abbreviate]; BlindCopyTo)|
varName = Evaluate(strMacro, doc)
For idx = 0 To Ubound(varName)
Call clsWord.Insert(Chr$(9) & varName(idx))
Call clsWord.Newline(1)
Next 'For idx = 0 To Ubound(varName)
Call clsWord.Newline(2)
Call clsWord.SetFontAttributes("Arial", 10, True, False, False)
Call clsWord.Insert("Thema: ")
Call clsWord.SetFontAttributes("Arial", 10, False, False, False)
Call clsWord.Insert(doc.Subject(0))
Call clsWord.Newline(2)
Call clsWord.ClearAllTabs
'einfügen des Mailinhaltes als Text
Set rtitem = doc.GetFirstItem( "Body" )
If ( rtitem.Type = RICHTEXT ) Then
Call clsWord.Insert(rtitem.GetFormattedText( False, 0 ))
End If 'If ( rtitem.Type = RICHTEXT ) Then
'Lösen der Anhänge ins gewählte Verzeichnis und einfügen eines Links in Dokument
intTitel = 0
idx = 0
If ( rtitem.Type = RICHTEXT ) Then
If xHasDocAttachments(doc) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
strFileName = Cstr(cFile.ExtractFilePath(cFile.Filename)) & o.Name
While Dir$(strFileName, 0) <> "" And intAbbruch <> 1
varResult = workspace.Prompt( PROMPT_OKCANCELEDIT, "Mail-Export", "Eine Datei mit diesem Namen ist bereits vorhanden." & Chr$(10) &_
"Bitte vergeben Sie einen anderen Namen", strFileName, "")
If Isempty(varResult) Then
intAbbruch = 1
Else
strFileName = Cstr(varResult)
End If 'If Isempty(varResult) Then
Wend 'Do While Dir$(strFileName, 0) <> ""
If intAbbruch Then Exit Forall
If intTitel = 0 Then
Call clsWord.Newline(2)
Call clsWord.Insert("Es sind folgende Dateianhänge vorhanden:")
Call clsWord.Newline(1)
intTitel = 1
End If 'If intTitel = 0 Then
Redim Preserve arrFiles(idx)
arrFiles(idx) = strFileName
idx = idx + 1
Call clsWord.InsertLink(strFileName, Cstr(cFile.ExtractFileName(strFileName)))
Call clsWord.Newline(1)
'Dateianhang lösen
Call o.ExtractFile (strFileName)
Setfileattr strFileName , ATTR_READONLY
End If
End Forall
End If 'If xHasDocAttachments(doc) Then
End If 'If ( rtitem.Type = RICHTEXT ) Then
If intAbbruch Then
'Export abgebrochen
'Word wird ohne zu speichern beendet
Call clsWord.CloseWord
Delete clsWord
'Alle bisher gelösten Dateien werden gelöscht
For idx = 0 To Ubound(arrFiles)
If arrFiles(idx) <> "" Then
Setfileattr arrFiles(idx) , ATTR_NORMAL
Kill arrFiles(idx)
End If 'If arrFiles(idx) <> "" Then
Next 'For idx = 0 To Ubound(arrFiles)
Messagebox "Der Export wurde abgegrochen.", 64, "Mail-Export"
Else
'Worddokument wird gespeichert und Word wird beendet
Call clsWord.SaveDoc(Cstr(cFile.Filename))
Call clsWord.CloseWord
Delete clsWord
'Setzen des Schreibschutzes auf Word-DAtei
Setfileattr Cstr(cFile.Filename), ATTR_READONLY
Messagebox "Das Mail wurde erfolgreich exportiert.", 64, "Mail-Export"
End If 'If intAbbruch Then
Exit Sub
ErrorHandling:
Messagebox "Das Mail konnte nicht exportiert werden." + Chr$(13) + "Fehler: " + Str$(Err) + " -> '" + Error$ + _
"' in Zeile " + Str$(Erl) , 16, "Mail-Export"
'Aufräumen
If Not (clsWord Is Nothing) Then
Call clsWord.CloseWord
Delete clsWord
End If 'If Not (clsWord Is Nothing) Then
Exit Sub
End Sub
Function xHasDocAttachments(doc As NotesDocument) As Integer
Dim vEval As Variant
vEval = Evaluate("@Attachments", doc)
If vEval(0) = 0 Then
xHasDocAttachments = False
Else
xHasDocAttachments = True
End If
End Function
Den Code der benötigten Script-Lib habe ich angehängt. Den Agent starte ich über einen Aktions-Button in der Memo- und den beiden Antwortmasken.
