Hallo,
wenn man einen Teil der Befehle, die wiederholt ausgeführt werden sollen in eine eigene Sub auslagert, kan man die zu suchenden und anzuhängenden Inhalte gut als Parameter übergeben.
Da der erste Parameter als byRef Parameter angegeben wurde, bleiben alle Änderungen in der Sub auch nach dem Durchlaufen erhalten.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMail As MailItem
On Error Resume Next
If Item.Class = olMail Then 'Ist eine Nachricht...
Set objMail = Item
' @hotmail.com
ReplaceWords(objMail, "@hotmail.com", "[Wichtig]")
' @web.de
ReplaceWords(objMail, "@web.de", "[Wichtig1]")
' @hotmail.de
ReplaceWords(objMail, "@hotmail.de", "[Wichtig2]")
' @msn.de
ReplaceWords(objMail, "@msn.de", "[Wichtig3]")
End If
End Sub
Private Sub ReplaceWords(ByRef objMail As MailItem, ByVal SearchText As String, ByVal AttachText As String)
Dim strSubj As String
Dim I&, tmp As Variant, blnHasDate As Boolean
On Error Resume Next
With objMail
If InStr(LCase$(.to), SearchText) _
<> 0 Then 'Betreff ggf. anpassen
tmp = Split(.Subject, " ")
For I = 0 To UBound(tmp)
While Right(tmp(I), 1) = "."
tmp(I) = Left(tmp(I), Len(tmp(I)) - 1)
Wend
If IsDate(tmp(I)) Then
blnHasDate = True
Exit For
End If
Next I
If Not blnHasDate Then 'Datum hinzufügen
For I = 0 To UBound(tmp)
strSubj = strSubj & tmp(I) & " "
Next I
.Subject = strSubj & AttachText
.Save
End If
End If
End With
End Sub
Die VBA-Funktion wurde nicht getestet, sollte aber so funktionieren, da lediglich die festen Suchbegriffe gegen Parameter ausgetauschr wurden.
LG, Ben
|