tecattack
Goto Top

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.

Bsp.:
1) SenderName = "Müller, Peter"
2) Makro laufen lassen
3) 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 lassen
3) Im Betreff erscheint nur "Schmidt"

Kann mir jemand weiterhelfen?

Vielen Dank! face-smile
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

Content-ID: 137951

Url: https://administrator.de/forum/outlook-2003-sp3-makro-sendername-im-betreff-einfuegen-137951.html

Ausgedruckt am: 24.12.2024 um 12:12 Uhr

76109
76109 11.03.2010 um 09:46:17 Uhr
Goto Top
Hallo TecAttack!

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
TecAttack
TecAttack 11.03.2010 um 10:08:30 Uhr
Goto Top
Hallo Dieter,

Vielen Dank !!! Nun hast du mir schon 2 super Tipps/Lösungen gegeben face-smile

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
76109
76109 11.03.2010 um 10:40:56 Uhr
Goto Top
Hallo TecAttack!

Zitat von @TecAttack:
Vielen Dank !!! Nun hast du mir schon 2 super Tipps/Lösungen gegeben face-smile
Yepp, gern geschehenface-wink
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 selbstface-smile

Gruß Dieter
TecAttack
TecAttack 15.03.2010 um 10:46:36 Uhr
Goto Top
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

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
76109
76109 15.03.2010 um 11:14:12 Uhr
Goto Top
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.
'FullSender = Split(Replace(objItem.SenderName, ",", " "))

Gruß Dieter
Hody72
Hody72 28.10.2010 um 10:02:53 Uhr
Goto Top
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