Forumbeitrag
Excel-Version des Fragestellers:
365 Business
Erfahrungslevel des Fragestellers:
Excel gut - VBA bescheiden
Sunnyml
30.07.2025 18:37:55
VBA Code wird nicht ausgeführt
Hallo,
gerne möchte ich die Bezeichnung des Anhangs im Outlook als Betreff erhalten. Jetzt habe ich schon einige Codes ausprobiert. Seht ihr eine Fehler?
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
gerne möchte ich die Bezeichnung des Anhangs im Outlook als Betreff erhalten. Jetzt habe ich schon einige Codes ausprobiert. Seht ihr eine Fehler?
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
Als Antwort auf diesen Beitrag
Folgenachrichten
- Dass wir hier in einem Excel-Forum sind … - von RPP63 am 30.07.2025 19:42:32
- AW: Dass wir hier in einem Excel-Forum sind … - von xlKing am 30.07.2025 20:01:58
- AW: VBA Code wird nicht ausgeführt - von ralf_b am 30.07.2025 21:50:03
Antwort auf Beitrag erstellen