|
Hallo Zusammen,
ich wollte für Outlook ein Makro schreiben, dass das Senden eine E-Mail verhindert, sobald bestimmte Wörter darin auftauchen. Das klappt mit der Funktion Application_ItemSend auch ganz gut - zumindest beim Schreiben einer neuen E-Mail. Über CurrentItem bekomme ich Betreff und E-Mail Inhalt und kann dann, je nachdem ob diese Worte enthalten sind, eine PopUp-Nachricht ausgeben und den Versand mit Cancel = true abbrechen.
Das Problem ist nun, dass der Skript auch beim Antworten auf eine E-Mail laufen soll. Diesmal komme ich über CurrentItem nicht an Betreff und Inhalt der Mail heran. Scheinbar existiert das Objekt an dieser Stelle nicht und ich bekomme einen Laufzeitfehler.
Mit Application.ActiveExplorer.Selection.Item(1) bekomme ich auch nur die Mail, die ich erhalten habe. Ich brauche aber den neuen Betreff und Inhalt, den ich beim Antworten in die Mail schreibe.
Kann mir da jemand weiterhelfen?
Das ist momentan mein Quelltext. Sicherlich sind auch so noch ein paar Sachen die man verbessern kann. Den Laufzeitfehler mit On Error zu umgehen ist nicht gerade sehr sauber. Erstmal müsste ich aber beim Antworten aber an die richten Werte herankommen.
' Suchfunktion zum Finden von Wörtern in einem String
Function FindStr(strAll As String, strPart As String) As Boolean
Dim x As Boolean
FindStr = InStr(1, strAll, strPart) > 0
End Function
' Funktion die beim Betätigen der Senden-Taste ausgeführt wird
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim NewMail As Outlook.MailItem
On Error Resume Next
Set NewMail = Application.ActiveInspector.CurrentItem
If Err.Number > 0 Then
End If
Dim words As Variant
' Sperrwörter in Array eintragen
words = Array("Bilanz", "Gehalt", "Vertraulich", "Lohn")
Dim element As Variant
Dim y As Boolean
For Each element In words
' Betreff auf aktuelles Sperrwort (Arrayelement) überprüfen. Abbruch der Schleife beim Auftauchen eines Wortes
y = FindStr(NewMail.Subject, CStr(element))
' Wurde im Betreff kein gesperrtes Wort gefunden, den Inhalt der E-Mail ebenfalls prüfen
If y = False Then
y = FindStr(NewMail.Body, CStr(element))
End If
If y = True Then Exit For
Next element
If y = True Then
' Enthält der Betreff ein Sperrwort, Fehlermeldung als Popup ausgeben und Sendevorgang nicht ausführen
bMessage = "Der Betreff oder Inhaltstext enthält eines oder mehrere der folgenden, gesperrten Wörter: "
' Ausgabe der Fehlermeldung und der gesperrten Wörter
Dim i As Byte
i = 0
For Each element In words
If i = 0 Then
bMessage = bMessage & " " & CStr(element)
Else
bMessage = bMessage & ", " & CStr(element)
End If
i = i + 1
Next element
MsgBox (bMessage)
Cancel = True
End If
End Sub
|