|
Hallo Zusammen,
mein VBA Code wird nicht ausgeführt. Kennt
jemand den Fehler? Outlook 365 Betreff wie Datei Name im Anhang.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMail As MailItem
Dim objAtt As Attachment
Dim strSubject As String
Dim strNewSubject As String
Dim Antwort As VbMsgBoxResult
' Nur fortfahren, wenn es sich um eine Mail handelt
If TypeName(Item) = "MailItem" Then
Set objMail = Item
' Wenn keine Anhänge vorhanden sind, kein Dialog notwendig
If objMail.Attachments.Count = 0 Then Exit Sub
' Benutzer fragen
Antwort = MsgBox("Anhänge automatisch im Betreff ergänzen?", vbYesNo + vbQuestion, "Betreff-Anpassung")
If Antwort = vbYes Then
strSubject = objMail.Subject
strNewSubject = strSubject
For Each objAtt In objMail.Attachments
If InStr(1, strNewSubject, objAtt.FileName, vbTextCompare) = 0 Then
If strNewSubject = "" Then
strNewSubject = objAtt.FileName
Else
strNewSubject = strNewSubject & " - " & objAtt.FileName
End If
End If
Next objAtt
' Nur setzen, wenn sich etwas geändert hat
If strNewSubject <> strSubject Then
objMail.Subject = strNewSubject
End If
End If
End If
' Aufräumen
Set objAtt = Nothing
Set objMail = Nothing
End Sub
Danke im voraus
|