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