(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
(Options) - Section
Option Public
Use "libWord"
Use "FileLibrary"
...
Option Public
%INCLUDE "LSCONST.LSS"
'Struktur für Dateidialoge definieren
Type fileDlgStruct
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
'Funktionen aus DLL
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (fileDlg As fileDlgStruct) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (fileDlg As fileDlgStruct) As Long
'Konstanten für Dateidialog festlegen
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_EXPLORER = &H80000
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_LONGNAMES = &H200000
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NOLONGNAMES = &H40000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHAREAWARE = &H4000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
Const OFN_SHOWHELP = &H10
'Klasse cFiel
Class cFile
'öffentliche Eigenschaften der Klasse
Public DefaultDir As String 'Vorgabeverzeichnis
Public DefaultFilename As String 'Vorgabedateiname
Public FileName As String 'gewählter Dateiname incl. Verzeichnis
Public FileTitle As String 'gewählter Dateiname
Public Filter As String 'Liste für Filter
Public FilterIndex As Integer 'Index für Vorgabefilter
Public Title As String 'Titel der Dialogbox
'private Klasseneigenschaften
myfileDlg As fileDlgStruct
'Methode für Datei-Öffnen Dialog
Function FileOpenDlg () As Integer
Dim APIResults As Integer
Dim szFileName As String *255
Dim szFileTitle As String *255
Dim szCurrentDir As String *255
Dim Index As Integer
'Speicher für Rückgabestrings allokieren
szFileName = Chr$(0) & Space$(255) & Chr$(0)
szFileTitle = Space$(255) & Chr$(0)
'Vorgabe - Extension initialisieren.
DefExt = Chr$(0)
'Vorgabewerte setzen
szCurrentDir = DefaultDir & Chr$(0)
szFileName = DefaultFileName & Chr$(0)
Title = Title & Chr$(0)
'FilterIndex prüfen
If FilterIndex <= 0 Then FilterIndex = 1
'Initialisierung der Datenstruktur
myFileDlg.lStructSize = Len(myFileDlg)
myFileDlg.hwndOwner = 0& 'If the OpenFile Dialog box is not linked to any form use this line.It will pass a null pointer.
myFileDlg.lpstrFilter = Filter
myFileDlg.nFilterIndex = FilterIndex
myFileDlg.lpstrFile = szFileName
myFileDlg.nMaxFile = Len(szFileName)
myFileDlg.lpstrFileTitle = szFileTitle
myFileDlg.nMaxFileTitle = Len(szFileTitle)
myFileDlg.lpstrTitle = Title
myFileDlg.Flags = OFN_LONGNAMES + OFN_HIDEREADONLY + OFN_PATHMUSTEXIST
myFileDlg.lpstrDefExt = DefExt
myFileDlg.hInstance = 0
myFileDlg.lpstrCustomFilter = 0
myFileDlg.nMaxCustFilter = 0
myFileDlg.lpstrInitialDir = szCurrentDir
myFileDlg.nFileOffset = 0
myFileDlg.nFileExtension = 0
myFileDlg.lCustData = 0
myFileDlg.lpfnHook = 0
myFileDlg.lpTemplateName = 0
'Anzeigen des Dialoges
APIResults = GetOpenFileName(myFileDlg)
'Bearbeiten der Rückgabewerte
If APIResults <> 0 Then
szFileName = Cstr( myFileDlg.lpstrFile )
szFileTitle = Cstr( myFileDlg.lpstrFileTitle )
FileName = Left$(szFileName, Instr(szFileName, Chr$(0)))
FileTitle = Left$(szFileTitle, Instr(szFileTitle, Chr$(0)))
FileOpenDlg = 1
Else
FileOpenDlg = 0
End If 'If APIResults <> 0 Then
End Function 'Function FileOpenDlg () As Integer
'Methode für Datei-Speichern Dialog
Function FileSaveDlg()
Dim APIResults As Integer
Dim szFileName As String *255
Dim szFileTitle As String *255
Dim szCurrentDir As String *255
'Speicher für Rückgabestrings allokieren
FileName = Chr$(0) & Space$(255) & Chr$(0)
szFileTitle = Space$(255) & Chr$(0)
'Vorgabe - Extension initialisieren.
DefExt = Chr$(0)
'Setzen der Vorgabewerte
szCurrentDir = DefaultDir & Chr$(0)
szFileName = DefaultFileName & Chr$(0)
Title = Title & Chr$(0)
'FilterIndex prüfen
If FilterIndex <= 0 Then FilterIndex = 1
'Initialisierung der Datenstruktur
myFileDlg.lStructSize = Len(myFileDlg)
myFileDlg.hwndOwner = 0& 'If the OpenFile Dialog box is not linked to any form use this line.It will pass a null pointer.
myFileDlg.lpstrFilter = Filter
myFileDlg.nFilterIndex = FilterIndex
myFileDlg.lpstrFile = szFileName
myFileDlg.nMaxFile = Len(szFileName)
myFileDlg.lpstrFileTitle = szFileTitle
myFileDlg.nMaxFileTitle = Len(szFileTitle)
myFileDlg.lpstrTitle = Title
myFileDlg.Flags = OFN_FILEMUSTEXIST + OFN_LONGNAMES + OFN_HIDEREADONLY + OFN_PATHMUSTEXIST
myFileDlg.lpstrDefExt = DefExt
myFileDlg.hInstance = 0
myFileDlg.lpstrCustomFilter = 0
myFileDlg.nMaxCustFilter = 0
myFileDlg.lpstrInitialDir = szCurrentDir
myFileDlg.nFileOffset = 0
myFileDlg.nFileExtension = 0
myFileDlg.lCustData = 0
myFileDlg.lpfnHook = 0
myFileDlg.lpTemplateName = 0
'Anzeigen des Dialoges
APIResults = GetSaveFileName(myFileDlg)
'Bearbeiten der Rückgabewerte
If APIResults <> 0 Then
szFileName = Cstr( myFileDlg.lpstrFile )
szFileTitle = Cstr( myFileDlg.lpstrFileTitle )
FileName = Left$(szFileName, Instr(szFileName, Chr$(0)))
FileTitle = Left$(szFileTitle, Instr(szFileTitle, Chr$(0)))
FileSaveDlg = 1
Else
FileSaveDlg = 0
End If 'If APIResults <> 0 Then
End Function 'Function FileSaveDlg()
'Methode zum Prüfen ob ein Verzeichnis vorhanden ist
Function IsValidDir(sPath As String) As Integer
On Error Resume Next
attr% = Getfileattr(sPath)
If Err > 0 Then
IsValidDir = 0
Exit Function
End If 'If Err > 0 Then
If (attr% And ATTR_DIRECTORY) Then IsValidDir = 1
End Function 'Function IsValidDir(sPath As String) As Integer
'Methode zum Anlegen von Verzeichnissen
Function MakeDir (sPath As String) As Integer
Dim sNewPath As String
Dim iPosi As Integer
If Right$(sPath,1) <> "\" Then sPath = sPath & "\"
MakeDir = 1
On Error Goto MakeDirError
Do
iPosi = Instr(iPosi + 1, sPath, "\")
If iPosi > 0 Then
sNewPath = Left$(sPath, iPosi - 1)
If Me.IsValidDir(sNewPath) = 1 Then
Mkdir sNewPath
End If 'IsValidDir(sNewPath) = 0...
End If 'iPosi > 0...
Loop Until iPosi = 0
MakeDir = 0
Ende:
Exit Function
MakeDirError:
Messagebox "Error " & Str(Err) & " : " & Error$
Resume Ende
End Function 'Function MakeDir (sPath As String) As Integer
'Methode zum Kopieren von einer Datei
'source -> Quelldatei incl. Verzeichnis
'destination -> Zielverzeichnis ohne Dateinamen
Function CopyFile(source As String, destination As String) As Integer
On Error Goto Errorhandler
If source = "" Then
Messagebox "Sie haben keine Quelldatei zum Kopieren angegeben." , MB_ICONEXCLAMATION, "Datei kopieren"
CopyFile = 1
Exit Function
End If 'If source = ""
If destination = "" Then
Messagebox "Sie haben keine Ziel zum Kopieren angegeben." , MB_ICONEXCLAMATION, "Datei kopieren"
CopyFile = 1
Exit Function
End If 'If destination = ""
If Strcompare(source, destination, 5) = 0 Then
Messagebox "Quelle und Ziel dürfen nicht gleich sein." , MB_ICONEXCLAMATION, "Datei kopieren"
CopyFile = 1
Exit Function
End If 'If StrCompare...
If Dir$(source, 0) = "" Then
Messagebox "Datei " & source & " ist nicht vorhanden" , MB_ICONEXCLAMATION, "Datei kopieren"
CopyFile = 1
Exit Function
End If 'If Dir$(source, 0) = ""
If Dir$( destination , 16) = "" Then
If Messagebox ("Verzeichnis " & destination & " ist nicht vorhanden" & Chr$(13) & Chr$(10) &"Möchten Sie das Verzeichnis erstellen?",_
MB_YESNO + MB_ICONQUESTION, "Datei kopieren" ) = IDYes Then
If Me.MakeDir(destination) = 1 Then
Messagebox "Verzeichnis " & destination & " konnte nicht angelegt werden" , MB_ICONEXCLAMATION, "Datei kopieren"
CopyFile = 1
Exit Function
End If 'If Me.MakeDir(destination) = 1 Then
Else
CopyFile = 1
Exit Function
End If 'If Messagebox ("Verzeichnis " & destination & " ist
End If 'If Dir$(destination, 16) = ""
If Right$(destination,1) <> "\" Then destination = destination & "\"
destination = destination & Me.ExtractFileName(source)
If Dir$(destination, 0) = destination Then
If Messagebox ("Datei " & destination & " ist bereits vorhanden." & Chr$(13) & Chr$(10) &"Möchten Sie die Datei überschreiben?", _
MB_YESNO + MB_ICONQUESTION, "Datei kopieren" ) = IDYes Then
Filecopy source, destination
Messagebox "Datei " & destination & " wurde erfolgreich kopiert", MB_ICONINFORMATION, "Datei kopieren"
CopyFile = 0
End If 'If Messagebox ("Datei existiert bereits. Überschreiben", ...
Else
Filecopy source, destination
Messagebox "Datei " & destination & " wurde erfolgreich kopiert", MB_ICONINFORMATION, "Datei kopieren"
CopyFile = 0
End If 'If Dir$(destination...
Ende:
Exit Function
ErrorHandler:
If Err = 76 Then
Resume Next
Else
Messagebox "Beim Kopieren ist ein Fehler aufgetreten." & Chr$(13) & Chr$(10) & "Fehlernr.: " & Str$(Err) & " -> " & Error$, _
MB_ICONSTOP, "Datei kopieren"
CopyFile = 1
Resume Ende
End If 'If Err = 76 Then
End Function 'Function CopyFile(source As String, destination As String) As Integer
'Methode zum extrahieren des Dateinamens
Function ExtractFileName( sPath As String) As String
Dim iPos As Integer
Dim iPosSave As Integer
Do
iPosi = Instr(iPosi + 1, sPath, "\")
If iPosi > 0 Then iPosSave = iPosi + 1
Loop Until iPosi = 0
ExtractFileName = Mid$(sPath,iPosSave)
End Function 'Function ExtractFileName( sPath As String) As String
'Methode zum Extrahieren des Verzeichnisteils
Function ExtractFilePath(sPath As String) As String
Dim iPos As Integer
Dim iPosSave As Integer
Do
iPosi = Instr(iPosi + 1, sPath, "\")
If iPosi > 0 Then iPosSave = iPosi
Loop Until iPosi = 0
ExtractFilePath = Left$(sPath,iPosSave)
End Function 'Function ExtractFilePath(sPath As String) As String
End Class 'Class cFile
@Command([ToolsRunMacro];"testagent")
Wenn das jeder bekommen soll, wieso baust du denn das nicht in die Schablone ein. Dann kümmert sich der Designtask um die Aktualisierung?
Call clsWord.InsertLink(strFileName, Cstr(cFile.ExtractFileName(strFileName)))Sub InsertLink(strFilename As String, strText As String)
Call objWord.ActiveDocument.Hyperlinks.Add(objWord.Selection.Range, strFilename, "", "", strText)
End SubWenn du alles komplett in der Schablone drin hast, Agent und Scriptbibliotheken, dann sollte der Designtask eigentlich den Rest machen. Läuft der Designtask bei euch überhaupt?
Prüf mal das log bzw. schau die mal die notes.ini des Servers an. In der Regel gibt's da eine Zeile ServertasksAt1=Design,....
Axel
Setz mal Option Declare in deinem Agent und in den Bibliotheken. Was sagt denn der Debugger zu dem Thema?
Also Design ist drin... aber hinter Catalog,... solllte es lieber andersherum sein?
Edit:
Es kommt beim jedem neustart von Notes ein Fenster auf, in dem er mit mitteilt, das etwas Aktualisiert wurde, und dann kann ich auf Aktualisieren klicken. Klicke ich drauf, läd er kurz was und sagt alles Aktualisiert, aber letzendlich ist nix passiert....