5
Outlook 2003 SP3 - Makro - AW oder WG im Betreff löschen lassen
Hallo,
Ich bekomme Emails mit unter anderem "AW: " und/oder "WG: " im Betreff, teilweise auch mehrfach im Betreff. Diese beiden Zusätze "AW: " und/oder "WG: " und andere würde ich gerne von einem Makro erkennen und entfernen lassen.
Leider muss ich sagen, dass ich nicht einmal weiß womit ich anfangen soll (bin Anfänger). Hab im Internet bisher nichts brauchbares gefunden
Das ganze würd ich in den unten angegebenen Code einpflegen wollen. Kann mir jemand auf die Sprünge helfen?
Gruß
TecAttack
Ich bekomme Emails mit unter anderem "AW: " und/oder "WG: " im Betreff, teilweise auch mehrfach im Betreff. Diese beiden Zusätze "AW: " und/oder "WG: " und andere würde ich gerne von einem Makro erkennen und entfernen lassen.
Leider muss ich sagen, dass ich nicht einmal weiß womit ich anfangen soll (bin Anfänger). Hab im Internet bisher nichts brauchbares gefunden
Das ganze würd ich in den unten angegebenen Code einpflegen wollen. Kann mir jemand auf die Sprünge helfen?
Gruß
TecAttack
Public Sub InsertDate()
'=====================================================================
' Fügt an den Anfang des Betreffs eines Elements das ErhaltenDatum & SenderName ein.
' 2008-11-21 - Version 1.0.0
'=====================================================================
Dim objItem As Object ' Aktuelles Element
Dim strDispSender As String
Dim i As Long
'---------------------------------------------------------------------
' 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
'---------------------------------------------------------------------
' 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
Auf Facebook teilen
Auf Twitter teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 137851
Url: https://administrator.de/contentid/137851
Ausgedruckt am: 23.11.2024 um 14:11 Uhr
5 Kommentare
Neuester Kommentar
Hallo,
Dieses hier ist nun mein erster Lösungsansatz:
Nun muss ich überlegen/testen ob das alles so schlau ist und wie ich es ins zuvor vorgestellte Makro reinpflege.
Für etwas Unterstützung wäre ich echt dankbar, sonst bastel ich noch nächstes dran rum
Gruß
TecAttack
Dieses hier ist nun mein erster Lösungsansatz:
Dim SubjectText, FindText, DeleteText
SubjectText = objItem.Subject
FindText = "AW:"
DeleteText = "Delete"
objItem.Subject = Replace (SubjectText, FindText, DeleteText) ' AW löschen Nun muss ich überlegen/testen ob das alles so schlau ist und wie ich es ins zuvor vorgestellte Makro reinpflege.
Für etwas Unterstützung wäre ich echt dankbar, sonst bastel ich noch nächstes dran rum
Gruß
TecAttack
Hallo TecAttack,
Dein Ansatz ist mehr als gut, ich habs mal in deinen anfangs gezeigten Code eingepflegt, hier unten ist das getestete und funktionierende Ergebnis!
Gruß
TecAttack
Dein Ansatz ist mehr als gut, ich habs mal in deinen anfangs gezeigten Code eingepflegt, hier unten ist das getestete und funktionierende Ergebnis!
Gruß
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
Hallo TecAttack!
Wobei man den Entfernen-Vorgang etwas verkürzen könnte:
Durch die Option [vbTextCompare], wird nicht zwischen Groß/Kleinschreibung unterschieden
Gruß Dieter
Wobei man den Entfernen-Vorgang etwas verkürzen könnte:
Const FindText = "AW, WG, RE, TR, RES, FW, RV, FWD, R" 'Komma als Trennzeichen
Dim ReplaceText As Variant, i As Integer
ReplaceText = Split(FindText, ",") 'FindText in ein Array splitten
For i = 0 To UBound(ReplaceText) 'Alle Elemente plus Doppelpunkt und Leerzeichen entfernen
objItem.Subject = Replace(objItem.Subject, Trim(ReplaceText(i)) & ": ", "", , , vbTextCompare)
NextGruß Dieter
Guten Morgen Dieter,
Vielen Dank für die Kurzversion! Ich versuch es mal einzupflegen.
Gruß
TecAttack
Vielen Dank für die Kurzversion! Ich versuch es mal einzupflegen.
Gruß
TecAttack
Moin,
Der Versuch war erfolgreich, hier unten nun das Ergebnis.
Gruß
TecAttack
Der Versuch war erfolgreich, hier unten nun das Ergebnis.
Gruß
TecAttack
Public Sub EditSubject()
'=====================================================================
' Zweck: Betreff wird wird wie folgt editiert:
'
' ErhaltenDatum einfügen
' SenderName einfügen
' AW, RE & Co löschen
'
' 15 March 2010
'=====================================================================
Const FindText = "AW, WG, RE, TR, RES, FW, RV, FWD, R" 'Komma als Trennzeichen
Dim ReplaceText As Variant, k As Integer
Dim objItem As Object ' Aktuelles Element
Dim strDispSender As String
Dim i As Long
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, WG, usw. löschen
'---------------------------------------------------------------------
ReplaceText = Split(FindText, ",") 'FindText in ein Array splitten
For k = 0 To UBound(ReplaceText) 'Alle Elemente plus Doppelpunkt und Leerzeichen entfernen
objItem.Subject = Replace(objItem.Subject, Trim(ReplaceText(k)) & ": ", "", , , vbTextCompare) 'Durch die Option [vbTextCompare], wird nicht zwischen Groß/Kleinschreibung unterschieden
Next
'---------------------------------------------------------------------
' 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
