Hallo Bernhard,
mein richtiger Name ist Okko, da ist Ork gar nicht so weit weg.
Ich habe den Code ein wenig abgekürzt, um mein Problem genauer zu schildern, aber wenn ein wenig gemäkelt ;-) wird, was ich natürlich als positive Kritik verstehe und versuche auch umzusetzen, füge ich mal den gesamten Quelltext ein. Ich hoffe (oder aber der Spezis schlagen die Hände über dem Kopf zusammen :-) ), da wird dann klarer, warum ich wie Bernhard so schön formuliert hat"den Stunt gewagt habe".
Hier der gesamte code:
Sub Click(Source As Button)
' DEKLARATION
' LN - Vorgaben
Dim workspace As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim newUiDoc As NotesUIDocument
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim newDoc As NotesDocument
Dim view As NotesView
Dim attachment As NotesRichTextItem ' Anhang
' Datei- und Verzeichnisverwaltung
Dim sourceFile As Variant ' Quelldatei im Netzwerk
Dim targetFile As String ' Zieldatei - nach dem Kopieren aus dem Netzwerk
Dim netDirectory As String ' Netwerkpfad zur Vorlagenauswahl
Dim nameProtocolFile As String ' Name der Protokolldatei
Dim protocolFile As String ' Pfad zur Protokolldatei
Dim localTargetDirectory As String ' Lokales Zielverzeichnis für die Word-Datei
Dim formats As String ' Formate, die in der Vorlagenauswahl angezeigt werden sollen
Dim wordObj As Variant ' Variable für die Word-Dokumenten-Verwaltung in Lotus Script
Dim fso As Variant ' Variable für die Verzeichnisverwaltung
' Meldungen
Dim faultMessageNetwork As String ' Fehlermeldung für nicht korrekten Netzwerkpfad
Dim faultMessageAttachment As String ' Fehlermeldung für schon vorhandenen Anhang
Dim faultMessageBody As String ' Fehlermeldung für schon eingetragenen Text im Body
Dim faultMessageTime As String ' Fehlermeldung für die Überschreitung der Wartezeit unter Word
Dim faultMessageWordFile As String ' Fehlermeldung für eine noch offene Temp-Datei - nicht zu speichern
Dim faultMessageWordSave As String ' Fehlermeldung für noch offene Word-Dokumente, die noch zu speichern sind
Dim infoMessage As String ' Hinweisnachricht für den Benutzer
' MS Word
Dim dateOldFile As String ' Änderungsdatum der Word-Datei
Dim dateNewFile As String ' Neues Änderungsdatum der Word-Datei
Dim waitingTime As Integer ' Wartezeit bis zur Abspeicherung des Word-Dokuments in Sekundensprüngen
Dim saveOptionsWordTime As String ' Speicheroptionen beim erzwungenem Schliessen von Word - gilt für alle geöffneten Dokumente
Dim wordAktiv As Boolean ' Schleifenvariable - MS Word aktiv = true, nicht aktiv = false
Dim splittedFile As String ' Name der ausgewählten Word-Datei
' E-Mail Angaben
Dim subject As String ' Mailbetreff
Dim email_Kdr As String, email_StffChef As String, email_StffFw As String, email_TEFhr As String
Dim emailA As String, email1 As String, email2 As String, email3 As String
' Protokollvariablen
' Die einzelnen Zeilen der Protokoll-Datei
Dim protocolLine1 As String, protocolLine2 As String, protocolLine3 As String, protocolLine4 As String, protocolLine5 As String, protocolLine6 As String, protocolLine7 As String
Dim dateTime As Variant ' Variable zum Auslesen der Antragszeit
Dim newDate As String, newTime As String ' Zeit kann nur als String in die Protokolldatei geschrieben werden
Dim name1 As String, name2 As String, name3 As String
' Diverse
Dim counter As Integer ' Zähler für Warteschleifen
Dim numOfAttachments As Variant ' Anzahl der enthaltenen Anhänge vor Benutung des Buttons
Dim textOfBody As String ' Text aus dem Body vor Benutzung des Buttons
' Datenbankzugriff
Dim addressbook As String
Dim viewData As String
Dim server As String
Dim userName As String
' INITIALISIERUNG
Set uidoc = workspace.CurrentDocument
Set doc = uidoc.Document
Set attachment = New NotesRichTextItem(doc, "attachment")
' WERTZUWEISUNGEN
' Wertzuweisungen für Datei- und Verzeichnisverwaltung
netDirectory = "C:\tmp" ' Netzwerkpfad zum Vorlagenordner
formats = "Microsoft Word|*.doc" ' Anzuzeigende Format in Vorlagenordner - nur MS Word
localTargetDirectory = "C:\Lotus\tmp" ' Ordner für temporäre Speicherung von MS Word-Datei und Potokoll-Datei
nameProtocolFile = "Protokoll-EMail-Authentifiizierung" & ".txt" ' Name der Protokolldatei
protocolFile = localTargetDirectory & "\" & nameProtocolFile ' Pfad zur Protokolldatei
' Meldungen
faultMessageNetwork = "Beim Öffnen des Netzwerkordners ist ein Fehler aufgetreten! Der Vorgang wird hiermit beendet!"
infoMessage = "Bitte vergessen Sie nicht die Datei in Microsoft Word zu speichern!"
faultMessageWordTime = "Die Wartezeit zum Abspeichern des Dokuments wurde überschritten! Der Vorgang wird hiermit beendet!"
faultMessageWordSave = "Ein offenes Microsoft Word-Dokument verhindert den korrekten Ablauf des Programms! Bitte speichern Sie Ihr(e) Dokument(e)!"
faultMessageWordFile = "Ein offenes Microsoft Word-Dokument verhindert den korrekten Ablauf des Programms! Microsoft Word wird nun geschlossen!"
faultMessageAttachment = "Es existiert bereits ein Datei-Anhang! Dieser Vorgang steht somit nicht mehr zur Verfügung und wird hiermit beendet!"
faultMessageBody = "Es wurde bereits Text in die E-Mail eingetragen! Dieser darf erst nach dem Anhang der Vorlagen eingetragen werden!Der Vorgang wird hiermit beendet!"
' MS Word
waitingTime = 20 ' Enstpricht 20 Sekunden, bevor MS Word mit Fehlermeldung geschlossen wird
saveOptionsWordTime = "0" ' 0 - speichern wird nicht abgefragt, 1- speichern wird vor dem Schließen abgefragt
' Datenbankangaben
userName = Environ$("username") ' Name des Antragssteller, ausgelesen aus Umgebungsvariable
server = "ln-server/certifier" ' Name des Mailservers
addressbook = "names.nsf" ' Name des Adressbuchs
dataView= "People" ' Name der Ansicht aus Adressbuch
' Diverse Angaben
counter = 0 ' Zählvariable für mehrere Schleifen
wordAktiv = True ' Setzt die Variable auf: MS Word ist noch aktiv -> Schleifenvariable
'_________________________________________________________________________________________
'FEHLERVORBEUGUNG
' löscht alle Einträge im E-Mail-Kopf
uidoc.FieldClear("EnterSendTo")
uidoc.FieldClear("EnterCopyTo")
uidoc.FieldClear("EnterBlindCopyTo")
uidoc.FieldClear("FaxToList")
uidoc.FieldClear("subject")
' Liest den Text aus dem Body aus
textOfBody = uidoc.FieldGetText("Body")
If Len(textOfBody) > 0 Then
Msgbox faultMessageBody,MB_OK & MB_ICONSTOP ,"Warnhinweis"
uidoc.FieldClear("Body")
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
' Prüft, ob sich schon ein Anhang in dem Dokument befindet.
' Nutzung der Formelsprache
Const NotesMacro$ = "@Attachments"
' Gibt die Anzahl der Anhänge aus
numOfAttachments = Evaluate(NotesMacro$, doc)
If numOfAttachments(0) > 0 Then
Msgbox faultMessageAttachment,MB_OK & MB_ICONSTOP ,"Warnhinweis"
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'_________________________________
' Netzwerk-Prüfung über Pfad
' Falls das Netzwerkverzeichnis nicht vorhanden ist, wir der Vorgang abgebrochen
If Dir$(netDirectory,16) = "" Then
Msgbox faultMessageNetwork,MB_OK & MB_ICONSTOP ,"Warnhinweis"
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'__________________________________________________________________________________________
' Verzeichnisbearbeitung
' Löscht Zwischenverzeichnis alter Dokumente
If Dir$(localTargetDirectory,16) <> "" Then
Set fso = createObject("Scripting.FileSystemObject")
Do
On Error Resume Next
fso.deleteFolder localTargetDirectory, False
If Err = 213 Then ' Falls das zu verwendende Dokument bereits in MS Word geöffnet ist, wird es geschlossen
Err = 0
Msgbox faultMessageWordFile,MB_OK & MB_ICONEXCLAMATION,"Information"
Set wordObj = getObject("","Word.Application")
wordObj.Application.quit saveOptionsWordTime
Call wordObj.quit() ' Verbindung zu MS Word löschen
Set wordObj = Nothing ' Verbindung zu MS Word löschen
Msgbox "Microsoft Word wurde beendet!",MB_OK & MB_ICONINFORMATION ,"Hinweis"
Else
wordAktiv = False
' Erzeugt neuen Ordner, weil der alte gelöscht wurde
Mkdir localTargetDirectory
End If
Loop While wordAktiv = True
Else
' Wenn noch kein Ordner da, erstelle einen
Mkdir localTargetDirectory
End If
' Setzt die Variable wieder der Anfangswert
wordAktiv = True
'_________________________________________________________________________________________
' PROGRAMMSTART
' Netzwerk-Vorlage wird lokal gespeichert
' Öffnet den Netzordner zur Dateiauswahl
sourceFile = workspace.OpenFileDialog(False,"Vorlagenauswahl",formats,netDirectory)
' Prüfe ob eine Datei vorhanden ist
If Isempty(sourceFile) Then Exit Sub
' Datei umbenennen (mit neuem Verzeichnis)
targetFile = localTargetDirectory &"\Word_" & Cstr(Today) & ".doc"
Filecopy sourceFile(0) , targetFile
' Speichert das aktuelle Datum in einer Variablen
dateOldFile = Filedatetime(targetFile)
'__________________________________________________________________________________________
' Microsoft Word
' Ein laufendes MS Word wird geschlossen
' Benutzerhinweis
Msgbox infoMessage,MB_OK & MB_ICONEXCLAMATION,"Information"
' Damit MS Word nicht mit einem Fehler abbricht, muss MS Word vorher geschlossen sein bzw. geschlossen werden
Do
On Error Resume Next
Set wordObj = getObject("","Word.Application")
If Err = 208 Then ' Wenn MS Word nicht aktiv ist, wird der Fehler auf 0 gesetzt und die Schleife wird verlassen
Err = 0
wordAktiv = False
Else ' Word ist mit Dokument(en) aktiv
Msgbox faultMessageWordSave,MB_OK & MB_ICONEXCLAMATION,"Information"
wordObj.Application.WindowState = 2 ' Wordfenster minimiert
wordObj.Application.WindowState = 1 ' Wordfenster maximiert
wordObj.Application.quit ' Word wird geschlossen
Msgbox "Microsoft Word wurde beendet!",MB_OK & MB_ICONINFORMATION ,"Hinweis" ' Stop in dem Programm, um dem Nutzer die Zeit für das Speichern zu gewähren
End If
Loop While wordAktiv = True
' Verbindung zwischen Variable und MS Word löschen
Call wordObj.quit()
Set wordObj = Nothing
'_________________________________
' Öffnet Microsoft Word mit ausgewählter Word-Datei
Set wordObj = getObject(targetFile,"Word.Document")
' Word wird als aktives Fenster angezeigt
wordObj.Application.Visible = True
wordObj.Application.WindowState = 1
'_________________________________
'Schliessen von MS Word
' Überprüft, ob das Word-Dokument in geänderterweise gespeichert worden ist. Falls
' während der Überprüfung die Wartezeit überschritten wird, wird das Programm abgebrochen
Do
dateNewFile = Filedatetime(targetFile)
Sleep 1 ' wegen der CPU-Auslastung eingebaut - leichte Performance-Schwächen - kann auch entfernt werden
counter = counter +1 ' Zählvariable wird um 1 erhöht
If counter = waitingTime Then
wordObj.Application.quit saveOptionsWordTime
Msgbox faultMessageWordTime,MB_OK & MB_ICONSTOP ,"Warnhinweis"
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
Exit Do
End If
If dateOldFile <> dateNewFile Then
On Error Resume Next
wordObj.Application.quit saveOptionsWordTime ' Schließt nach dem Speichern des Doks das Programm MS Word
If Err = 207 Then Err = 0 ' Falls es vorher manuell geschlossen wird, wird der Fehler wieder auf 0 gesetzt
End If
Loop While dateOldFile = dateNewFile
'__________________________________________________________________________________________
' Erstellung der Log-Datei
' Datum für die Antragserstellung
' Splittet die Zeit der Dokumenten-Fertigstellung in Datum und Zeit
dateTime= Split(dateNewFile," ",2)
newDate = dateTime(0)
newTime = dateTime(1)
'__________________________________
' Verbindungsherstellung zu Personendaten
' Stellt die Verbindung zur Datenbank Adressbuch her und wählt das erste Dokument aus der Ansicht People aus -> erste Person
Set db = New NotesDatabase(server, addressbook)
Set view = db.GetView( dataView)
Set newDoc = view.GetFirstDocument
'__________________________________
' Suche der E-Mail-Adresse des Antragssteller
Do
' Falls das aktuelle Dokument mit dem NT Benutzernamen übereinstimmt, wird die E-Mail-Adresse erzeugt
If userName = getName(newDoc) Then
emailA = createEmail(newDoc)
Exit Do
End If
Set newDoc = view.GetNextDocument(newDoc) ' nächste Datensatz / Person
Loop While Not username = getName(newDoc)
'__________________________________
' Erstellt die E-Mail-Adressen für die Vorgesetzten
' Erstellt E-Mail vom Kommandeur
email_Kdr = createMailFromPerson("Kdr", newDoc, db)
If email_Kdr = "" Then
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'__________________________________
' Erstellt E-Mail vom Staffelchef
email_StffChef = createMailFromPerson("StffChef", newDoc, db)
If email_StffChef = "" Then
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'__________________________________
' Erstellt E-Mail vom TeileinheitsFührer
email_TEFhr = createMailFromPerson("TEFhr", newDoc, db)
If email_TEFhr = "" Then
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'__________________________________
' Erstellt E-Mail vom StaffelFeldwebel
email_StffFw = createMailFromPerson("StffFw", newDoc, db)
If email_StffFw = "" Then
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'Memo wird geschlossen
Exit Sub
End If
'__________________________________________________________________________________________
' Namensermittlung des ausgewählten Word-Dokuments
' Zählvariable für die Do-Schleife
counter = 0
' Name der ausgewählten Word-Vorlage wird ermittelt
' Der Pfad samt Word-Datei werden am Backslash aufgeteilt und als einzelne Elemente gespeichert
sourceFile = Split(sourceFile(0),"\")
' In der Schleife werden alle Elemente durchsucht, bis die Vorlage gefunden worden ist.
' Dann wird die Word-Vorlage vom Format getrennt und gespeichert.
Do
If sourceFile(counter) Like "*.doc" Then
sourceFile = Split(sourceFile(counter),".")
splittedFile = sourceFile(0)
End If
counter = counter + 1
Loop While sourceFile(1) <> "doc"
' Zählvariable wird wieder auf den Anfangswert gesetzt
counter = 0
'__________________________________
' Festlegung der Empänger anhand des ausgewählten Dokuments
Select Case splittedFile
Case "Urlaubsantrag":
subject = "Urlaubsantrag - " & userName
email1 = email_TEFhr
email2 = email_StffFw
email3 = email_StffChef
Case "Kfz-Anforderung":
subject = "Kfz-Anforderung - " & userName
email1 = email_TEFhr
email2 = email_StffChef
email3 = email_Kdr
End Select
' Zuteilung der Name durch die Angabe der E-Mail Adressen
name1 = getNameFromMail(email1)
name2 = getNameFromMail(email2)
name3 = getNameFromMail(email3)
'__________________________________
' Inhalt der Protokolldatei
protocolLine1 = " Protokoll-Datei"
protocolLine2 = " "
protocolLine3 = "Antragssteller: E-Mail: " & emailA & " Antrag erstellt am: " & newDate & " um " & newTime & " Name: " & userName
protocolLine4 = "________________________________________________________________________________________________________________________"
protocolLine5 = "Genehmigungsinhaber1: E-Mail: " & email1 & " Beurteilung: Zeit(Datum, Uhrzeit): Name: " & name1
protocolLine6 = "Genehmigungsinhaber1: E-Mail: " & email2 & " Beurteilung: Zeit(Datum, Uhrzeit): Name: " & name2
protocolLine7 = "Genehmigungsinhaber1: E-Mail: " & email3 & " Beurteilung: Zeit(Datum, Uhrzeit): Name: " & name3
fileNum = Freefile() ' Erzeugt eine ID für eine zu öffende Datei
Open protocolFile For Output As fileNum ' Öffnet die Datei aus protocolFile zur ID zum beschreiben
Print #fileNum,protocolLine1
Print #fileNum,protocolLine2
Print #fileNum,protocolLine3
Print #fileNum,protocolLine4
Print #fileNum,protocolLine5
Print #fileNum,protocolLine6
Print #fileNum,protocolLine7
Close #fileNum
'__________________________________________________________________________________________
' E-Mail - Einstellungen
doc.EnterSendTo = email1
doc.subject = subject
'__________________________________________________________________________________________
' Fügt die Dateien an
' Gehe zu Feld attachment
Call uidoc.GotoField("attachment")
' Hängt die Datei an, wenn attachment vom Typ Richtext ist und lässt sie anzeigen
If attachment.type = 1 Then
Call attachment.EmbedObject( EMBED_attachment, "",targetFile)
Call attachment.EmbedObject( EMBED_attachment, "",protocolFile)
Call attachment.Update
doc.SaveOptions = "0" 'speichern wird nicht abgefragt
Call uidoc.Close(True) 'wird geschlossen
Set newUiDoc = workspace.EditDocument(True, doc)
Delete uidoc 'Referenz auf das alte Frontend-Dokument löschen
Set Doc = newUiDoc.Document
Call doc.RemoveItem("SaveOptions")
newUiDoc.Refresh
End If
End Sub
Es gibt auch noch 5 Funktionen, bei denen ich aber nicht davon ausgehe, dass diese den Fehler verursachen können.
Hoffe weiterhin auf tolle Statements!!
LG Ork
@ Bernhard: LG Okko ;-)
