tecattack
Goto Top

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 face-sad

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

Content-ID: 137851

Url: https://administrator.de/forum/outlook-2003-sp3-makro-aw-oder-wg-im-betreff-loeschen-lassen-137851.html

Ausgedruckt am: 24.12.2024 um 13:12 Uhr

TecAttack
TecAttack 10.03.2010 um 14:20:34 Uhr
Goto Top
Hallo,

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 face-smile

Gruß
TecAttack
TecAttack
TecAttack 10.03.2010 um 16:11:20 Uhr
Goto Top
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

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
76109
76109 10.03.2010 um 21:59:31 Uhr
Goto Top
Hallo TecAttack!

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)  
Next
Durch die Option [vbTextCompare], wird nicht zwischen Groß/Kleinschreibung unterschieden

Gruß Dieter
TecAttack
TecAttack 11.03.2010 um 08:00:32 Uhr
Goto Top
Guten Morgen Dieter,

Vielen Dank für die Kurzversion! Ich versuch es mal einzupflegen.

Gruß
TecAttack
TecAttack
TecAttack 15.03.2010 um 11:29:01 Uhr
Goto Top
Moin,

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