Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMail As MailItem
On Error Resume Next
If Item.Class = olMail Then
Set objMail = Item
ReplaceWords(objMail, "@hotmail.com", "[Wichtig]")
ReplaceWords(objMail, "@web.de", "[Wichtig1]")
ReplaceWords(objMail, "@hotmail.de", "[Wichtig2]")
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
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
For I = 0 To UBound(tmp)
strSubj = strSubj & tmp(I) & " "
Next I
.Subject = strSubj & AttachText
.Save
End If
End If
End With
End Sub