6
Outlook 2003 SP3 - Makro - SenderName im Betreff einfügen
Hallo Zusammen,
Das folgende Makro fügt u.a. den Teil des SenderName ein der vor dem Komma ist. Das ist gut so und soll bleiben.
Mein Problem nun ist, dass ich auch emails bekomme bei denen SenderName = "Helga Maria Schmidt" ist. Hierfür dachte ich zunächst folgende beiden Lösungsbeschreibungen:
1) Wenn dieser Fall zutrifft müsste alle Zeichen bis zum nächsten Leerzeichen von hinten nach vorne in den Betreff kopiert werden.
2) Wenn dieser Fall zutrifft müssten alle Zeichen nach dem letzten Leerzeichen von vorne nach hinten in den Betreff kopiert werden.
Kann mir jemand weiterhelfen?
Vielen Dank!
TecAttack
Das folgende Makro fügt u.a. den Teil des SenderName ein der vor dem Komma ist. Das ist gut so und soll bleiben.
Bsp.:1) SenderName = "Müller, Peter"2) Makro laufen lassen3) Im Betreff erscheint nur "Müller"Mein Problem nun ist, dass ich auch emails bekomme bei denen SenderName = "Helga Maria Schmidt" ist. Hierfür dachte ich zunächst folgende beiden Lösungsbeschreibungen:
1) Wenn dieser Fall zutrifft müsste alle Zeichen bis zum nächsten Leerzeichen von hinten nach vorne in den Betreff kopiert werden.
2) Wenn dieser Fall zutrifft müssten alle Zeichen nach dem letzten Leerzeichen von vorne nach hinten in den Betreff kopiert werden.
Sollablauf:1) SenderName = "Helga Maria Schmidt"2) Makro laufen lassen3) Im Betreff erscheint nur "Schmidt"Kann mir jemand weiterhelfen?
Vielen Dank!
TecAttack
Public Sub EditSubject()
'=====================================================================
' Zweck: Betreff wird wird wie folgt editiert:
'
' ErhaltenDatum einfügen
' SenderName einfügen
' AW, RE & Co löschen
'
' 10 March 2010
'=====================================================================
Dim objItem As Object ' Aktuelles Element
Dim strDispSender As String
Dim i As Long
Dim SubjectText
Dim FindText1, FindText2, FindText3, FindText4, FindText5
Dim DeleteText
'---------------------------------------------------------------------
' Fehlerbehandlung wegen Set-Anweisungen ausschalten
'---------------------------------------------------------------------
On Error Resume Next
'---------------------------------------------------------------------
' Aktuell geöffnetes Element refernzieren
'---------------------------------------------------------------------
Set objItem = Outlook.ActiveInspector.CurrentItem
'---------------------------------------------------------------------
' Wenn kein Element geöffnet ist, dann markiertes verwenden
'---------------------------------------------------------------------
If objItem Is Nothing Then Set objItem = Outlook.ActiveExplorer.Selection(1)
'---------------------------------------------------------------------
' Auch nichts markiert?
'---------------------------------------------------------------------
If objItem Is Nothing Then GoTo ExitProc
'---------------------------------------------------------------------
' AW löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText1 = "AW: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText1, DeleteText)
'---------------------------------------------------------------------
' WG löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText2 = "WG: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText2, DeleteText)
'---------------------------------------------------------------------
' RE löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText3 = "RE: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText3, DeleteText)
'---------------------------------------------------------------------
' TR löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText4 = "TR: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText4, DeleteText)
'---------------------------------------------------------------------
' Re löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText5 = "Re: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText5, DeleteText)
'---------------------------------------------------------------------
' RES löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText6 = "RES: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText6, DeleteText)
'---------------------------------------------------------------------
' FW löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText7 = "FW: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText7, DeleteText)
'---------------------------------------------------------------------
' RV löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText8 = "RV: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText8, DeleteText)
'---------------------------------------------------------------------
' Fwd löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText9 = "Fwd: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText9, DeleteText)
'---------------------------------------------------------------------
' R löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText10 = "R: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText10, DeleteText)
'---------------------------------------------------------------------
' Nur das was vor dem Komma (soweit vorhanden) im SenderName
' enthalten ist übernehmen
'---------------------------------------------------------------------
i = InStr(1, objItem.SenderName, ",")
If (i > 0) Then
strDispSender = Left(objItem.SenderName, i - 1)
Else
strDispSender = objItem.SenderName
End If
'---------------------------------------------------------------------
' Erhalten Datum [yyyy-mm-dd] und obigen SenderName hinzufügen
'---------------------------------------------------------------------
' [alt] objItem.Subject = Format(Date, "yyyy-MM-dd") & " " & objItem.Subject
objItem.Subject = Format(objItem.ReceivedTime, "yyyy-MM-dd") & " " & strDispSender & " " & objItem.Subject
'---------------------------------------------------------------------
' Prüfung ob es sich um eine Email handelt oder nicht
'---------------------------------------------------------------------
If objItem.Class <> olMail Then GoTo ExitProc
'---------------------------------------------------------------------
' Änderung speichern
'---------------------------------------------------------------------
objItem.Save
ExitProc:
'---------------------------------------------------------------------
' Referenz auf Element löschen
'---------------------------------------------------------------------
Set objItem = Nothing
End Sub
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 137951
Url: https://administrator.de/contentid/137951
Printed on: April 19, 2024 at 03:04 o'clock
6 Comments
Latest comment
Hallo TecAttack!
Beispiel:
Result:
Gruß Dieter
Beispiel:
Const SenderName = "Helga Maria Schmidt"
Dim Sender As Variant, Betreff As String
Sender = Split(SenderName) 'Default ist Leerzeichen
Betreff = Sender(UBound(Sender)) 'Betreff = "Schmidt" Result:
| Helga Maria Schmidt | = | Schmidt |
| Maria Schmidt | = | Schmidt |
| Schmidt | = | Schmidt |
Gruß Dieter
Hallo Dieter,
Vielen Dank !!! Nun hast du mir schon 2 super Tipps/Lösungen gegeben
Für mich Anfänger sind VBA-technisch paar Sachen neu (auch was meine andere Frage angeht). Ich werde mich mal damit beschäftigen und stelle Ergebnis sobald wie möglich rein.
Gruß
TecAttack
Vielen Dank !!! Nun hast du mir schon 2 super Tipps/Lösungen gegeben
Für mich Anfänger sind VBA-technisch paar Sachen neu (auch was meine andere Frage angeht). Ich werde mich mal damit beschäftigen und stelle Ergebnis sobald wie möglich rein.
Gruß
TecAttack
Hallo TecAttack!
Yepp, gern geschehen
Gruß Dieter
Yepp, gern geschehen
Für mich Anfänger sind VBA-technisch paar Sachen neu (auch was meine andere Frage angeht). Ich werde mich mal damit
beschäftigen und stelle Ergebnis sobald wie möglich rein.
Tja, aller Anfang ist schwer, aber mit der Zeit kommt alles wie von selbstbeschäftigen und stelle Ergebnis sobald wie möglich rein.
Gruß Dieter
Moin,
Der obige Tipp eingepflegt in den obigen Code ergibt den hier unten folgenden erfolgreich getesteten Code. Nochmal danke Dieter! Deinen anderen Tipp bzgl. "AW, WG,..." muss ich noch einbauen. Meine nächsten Probleme und Fragen stehen schon in den Startlöchern, also bis dahin.
Gruß
TecAttack
Der obige Tipp eingepflegt in den obigen Code ergibt den hier unten folgenden erfolgreich getesteten Code. Nochmal danke Dieter! Deinen anderen Tipp bzgl. "AW, WG,..." muss ich noch einbauen. Meine nächsten Probleme und Fragen stehen schon in den Startlöchern, also bis dahin.
Gruß
TecAttack
Public Sub EditSubject()
'=====================================================================
' Zweck: Betreff wird wird wie folgt editiert:
'
' ErhaltenDatum einfügen
' SenderName einfügen
' AW, RE & Co löschen
'
' 11 March 2010
'=====================================================================
Dim objItem As Object ' Aktuelles Element
Dim strDispSender As String
Dim i As Long
Dim SubjectText
Dim FindText1, FindText2, FindText3, FindText4, FindText5
Dim DeleteText
Dim FullSender As Variant, PartSender As String
'---------------------------------------------------------------------
' Fehlerbehandlung wegen Set-Anweisungen ausschalten
'---------------------------------------------------------------------
On Error Resume Next
'---------------------------------------------------------------------
' Aktuell geöffnetes Element refernzieren
'---------------------------------------------------------------------
Set objItem = Outlook.ActiveInspector.CurrentItem
'---------------------------------------------------------------------
' Wenn kein Element geöffnet ist, dann markiertes verwenden
'---------------------------------------------------------------------
If objItem Is Nothing Then Set objItem = Outlook.ActiveExplorer.Selection(1)
'---------------------------------------------------------------------
' Auch nichts markiert?
'---------------------------------------------------------------------
If objItem Is Nothing Then GoTo ExitProc
'---------------------------------------------------------------------
' AW löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText1 = "AW: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText1, DeleteText)
'---------------------------------------------------------------------
' WG löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText2 = "WG: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText2, DeleteText)
'---------------------------------------------------------------------
' RE löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText3 = "RE: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText3, DeleteText)
'---------------------------------------------------------------------
' TR löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText4 = "TR: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText4, DeleteText)
'---------------------------------------------------------------------
' Re löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText5 = "Re: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText5, DeleteText)
'---------------------------------------------------------------------
' RES löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText6 = "RES: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText6, DeleteText)
'---------------------------------------------------------------------
' FW löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText7 = "FW: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText7, DeleteText)
'---------------------------------------------------------------------
' RV löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText8 = "RV: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText8, DeleteText)
'---------------------------------------------------------------------
' Fwd löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText9 = "Fwd: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText9, DeleteText)
'---------------------------------------------------------------------
' R löschen
'---------------------------------------------------------------------
SubjectText = objItem.Subject
FindText10 = "R: "
DeleteText = ""
objItem.Subject = Replace(SubjectText, FindText10, DeleteText)
'---------------------------------------------------------------------
' Nur Nachname kopieren, wenn Komma vorhanden
'---------------------------------------------------------------------
i = InStr(1, objItem.SenderName, ",")
If (i > 0) Then
strDispSender = Left(objItem.SenderName, i - 1)
objItem.Subject = Format(objItem.ReceivedTime, "yyyy-MM-dd") & " " & strDispSender & " " & objItem.Subject
Else
'---------------------------------------------------------------------
' Nur Nachname kopieren, wenn KEIN Komma vorhanden
'---------------------------------------------------------------------
FullSender = Split(objItem.SenderName) 'Default ist Leerzeichen
PartSender = FullSender(UBound(FullSender)) 'PartSender = „Nachname“
objItem.Subject = Format(objItem.ReceivedTime, "yyyy-MM-dd") & " " & PartSender & " " & objItem.Subject
End If
'---------------------------------------------------------------------
' Prüfung ob es sich um eine Email handelt oder nicht
'---------------------------------------------------------------------
If objItem.Class <> olMail Then GoTo ExitProc
'---------------------------------------------------------------------
' Änderung speichern
'---------------------------------------------------------------------
objItem.Save
ExitProc:
'---------------------------------------------------------------------
' Referenz auf Element löschen
'---------------------------------------------------------------------
Set objItem = Nothing
End Sub
Hallo TecAttack!
Falls die Namen auch Kommas enthalten, könntest Du, wie in diesem Beispiel, um auch dann das gleiche Ergebnis zu erhalten, die Kommas durch Leerzeichen ersetzen.
Gruß Dieter
Falls die Namen auch Kommas enthalten, könntest Du, wie in diesem Beispiel, um auch dann das gleiche Ergebnis zu erhalten, die Kommas durch Leerzeichen ersetzen.
| 'FullSender = Split(Replace(objItem.SenderName, ",", " ")) |
Gruß Dieter
Darf ich mich an diesen alten Thread bitte dranhängen? Danke!
mein Problem ist nämlich ähnlich und Folgendes - mein Chef möchte das wir bei Emails immer unser Kürzel - in meinem Fall PH - als erstes in den Email Betreff stellen - also noch vor das RE oder FW. Mails würden also so aussehen:
statt "RE: Bundzettel kindergarten heute" hiesse es "PH - RE: Bundzettel kindergarten heute" und
statt "FW: RE: Bundzettel kindergarten heute" hiesse es "PH - FW: Bundzettel kindergarten heute"
idealerweise sollte auch bei leeren Mails gleich "PH -" in leeren Mailformular stehen.
Lässt sich das irgendwo einstellen - Habe leider keine Ahnung von VBA.
Gibts da eine Lösung?
Vielen vielen Dank im Voraus
mein Problem ist nämlich ähnlich und Folgendes - mein Chef möchte das wir bei Emails immer unser Kürzel - in meinem Fall PH - als erstes in den Email Betreff stellen - also noch vor das RE oder FW. Mails würden also so aussehen:
statt "RE: Bundzettel kindergarten heute" hiesse es "PH - RE: Bundzettel kindergarten heute" und
statt "FW: RE: Bundzettel kindergarten heute" hiesse es "PH - FW: Bundzettel kindergarten heute"
idealerweise sollte auch bei leeren Mails gleich "PH -" in leeren Mailformular stehen.
Lässt sich das irgendwo einstellen - Habe leider keine Ahnung von VBA.
Gibts da eine Lösung?
Vielen vielen Dank im Voraus
