Suchen und Ersetzen in E-Mails

Zuletzt geändert am 03. April 2013

Mit diesem Beispiel können Sie bequem Suchen und Ersetzen in E-Mails.

Das Programm fragt alle Parameter ab und gibt am Ende eine Meldung mit der Anzahl der Ersetzungen im Betreff oder im Nachrichtentext aus.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Ab Outlook® 2002

Option Explicit
 
Public Sub SearchAndReplace()
 
    '=====================================================================
    ' Funktion zum Suchen und Ersetzen in E-Mails (Betreff oder Nachricht)
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-01-12 Version 1.0.0
    ' 2009-02-18 Version 1.0.1
    '=====================================================================

    Dim objFolder As Outlook.MAPIFolder
    Dim objItems As Object
    Dim objItem As Object
    Dim vbResult As VBA.VbMsgBoxResult
    Dim strSearch As String
    Dim strReplace As String
    Dim lngReplace As Long
    Dim blnSubject As Boolean
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Benutzer fragen, wo ersetzt werden soll
    '---------------------------------------------------------------------
    vbResult = MsgBox("Möchten Sie im Betreff ersetzen?" & vbCrLf & vbCrLf & _
        "Nein = Im Nachrichtentext ersetzen", vbQuestion + vbYesNoCancel, _
        "Suchen und Ersetzen")
 
    '---------------------------------------------------------------------
    ' Abbruch?
    '---------------------------------------------------------------------
    If vbResult = vbCancel Then Exit Sub
 
    '---------------------------------------------------------------------
    ' True = Betreff bearbeiten, False = Nachricht bearbeiten
    '---------------------------------------------------------------------
    If vbResult = vbYes Then blnSubject = True
 
    '---------------------------------------------------------------------
    ' Zu suchenden Begriff eingeben
    '---------------------------------------------------------------------
    strSearch = InputBox("Nach was soll gesucht werden?", "Suchen und Ersetzen" _
        , GetSetting("VBA-Project", "SearchAndReplace", "SearchString"))
 
    '---------------------------------------------------------------------
    ' Abbruch?
    '---------------------------------------------------------------------
    If strSearch = "" Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Suchbegriff speichern
    '---------------------------------------------------------------------
    Call SaveSetting("VBA-Project", "SearchAndReplace", "SearchString", strSearch)
 
    '---------------------------------------------------------------------
    ' Zu ersetztenden Begriff eingeben
    '---------------------------------------------------------------------
    strReplace = InputBox("Womit soll ersetzt werden?" & vbCrLf & vbCrLf & _
        "Um zu löschen, bitte ""DELETE"" eingeben.", "Suchen und Ersetzen" _
        , GetSetting("VBA-Project", "SearchAndReplace", "ReplaceString"))
 
    '---------------------------------------------------------------------
    ' Abbruch?
    '---------------------------------------------------------------------
    If strReplace = "" Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Löschen?
    '---------------------------------------------------------------------
    If Replace(strReplace, """", "") = "DELETE" Then strReplace = ""
 
    '---------------------------------------------------------------------
    ' Ersetzenbegriff speichern
    '---------------------------------------------------------------------
    Call SaveSetting("VBA-Project", "SearchAndReplace", "ReplaceString", strReplace)
 
    '---------------------------------------------------------------------
    ' E-Mail-Ordner auswählen
    '---------------------------------------------------------------------
    Set objFolder = ChooseFolder
 
    '---------------------------------------------------------------------
    ' Auswahl abgebrochen?
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Alle Elemente im Ordner referenzieren
    '---------------------------------------------------------------------
    Set objItems = objFolder.Items
 
    '---------------------------------------------------------------------
    ' Alle Elemente bearbeiten
    '---------------------------------------------------------------------
    For Each objItem In objItems
 
        '-----------------------------------------------------------------
        ' Je nach dem, wo ersetzt werden soll, wird jetzt der Betreff bzw.
        ' die Nachricht bearbeitet.
        '-----------------------------------------------------------------
        If blnSubject Then
 
            '-------------------------------------------------------------
            ' Enthält der Betreff den gesuchten Begriff?
            '-------------------------------------------------------------
            If InStr(objItem.Subject, strSearch) Then
 
                '---------------------------------------------------------
                ' Betreff ersetzen
                '---------------------------------------------------------
                objItem.Subject = Replace(objItem.Subject, strSearch, strReplace)
 
                '---------------------------------------------------------
                ' Änderung speichern
                '---------------------------------------------------------
                objItem.Save
 
                '---------------------------------------------------------
                ' Zähler erhöhen
                '---------------------------------------------------------
                lngReplace = lngReplace + 1
 
            End If
 
        Else
 
            '-------------------------------------------------------------
            ' Nur-Text oder HTML-Nachricht? (RTF kann nicht ersetzt werden)
            '-------------------------------------------------------------
            If objItem.BodyFormat = 1 Then
 
                '---------------------------------------------------------
                ' Enthält die Nachricht den gesuchten Begriff?
                '---------------------------------------------------------
                If InStr(objItem.Body, strSearch) Then
 
                    '-----------------------------------------------------
                    ' Nur-Text-Nachricht ersetzen
                    '-----------------------------------------------------
                    objItem.Body = Replace(objItem.Body, strSearch, strReplace)
 
                    '-----------------------------------------------------
                    ' Änderung speichern
                    '-----------------------------------------------------
                    objItem.Save
 
                    '-----------------------------------------------------
                    ' Zähler erhöhen
                    '-----------------------------------------------------
                    lngReplace = lngReplace + 1
 
                End If
 
            ElseIf objItem.BodyFormat = 2 Then
 
                '---------------------------------------------------------
                ' Enthält die Nachricht den gesuchten Begriff?
                '---------------------------------------------------------
                If InStr(objItem.HTMLBody, strSearch) Then
 
                    '-----------------------------------------------------
                    ' HTML-Nachricht ersetzen
                    '-----------------------------------------------------
                    objItem.HTMLBody = Replace(objItem.HTMLBody, strSearch, strReplace)
 
                    '-----------------------------------------------------
                    ' Änderung speichern
                    '-----------------------------------------------------
                    objItem.Save
 
                    '-----------------------------------------------------
                    ' Zähler erhöhen
                    '-----------------------------------------------------
                    lngReplace = lngReplace + 1
 
                End If
 
            End If
 
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer
    '---------------------------------------------------------------------
    If blnSubject Then
        MsgBox "Ersetzungen im Betreff: " & lngReplace, _
            vbInformation, "Suchen und Ersetzen"
    Else
        MsgBox "Ersetzungen im Nachrichtentext: " & lngReplace, _
            vbInformation, "Suchen und Ersetzen"
    End If
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objItem = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Function ChooseFolder() As Outlook.MAPIFolder
 
    '=====================================================================
    ' Gibt einen ausgewählten E-Mailordner zurück
    ' 2009-01-12 Version 1.0.0
    '=====================================================================
 
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Hinweis anzeigen
    '---------------------------------------------------------------------
    If MsgBox("Bitte wählen Sie im nächsten Dialog den" & vbCrLf & _
        "zu bearbeitenden E-Mailordner aus.", vbInformation _
        + vbOKCancel, "Suchen und Ersetzen") = vbCancel Then Exit Function
 
    '---------------------------------------------------------------------
    ' Schleife wird solange durchlaufen, bis ein gültiger Ordner ausgewählt
    ' oder die Auswahl abgebrochen wird.
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Ordnerauswahl anzeigen
        '-----------------------------------------------------------------
        Set objFolder = Nothing
        Set objFolder = Outlook.Session.PickFolder
 
        '-----------------------------------------------------------------
        ' Wurde die Auswahl abgebrochen?
        '-----------------------------------------------------------------
        If objFolder Is Nothing Then Exit Function
 
        '-----------------------------------------------------------------
        ' Falscher Ordnertyp ausgewählt?
        '-----------------------------------------------------------------
        If InStr(objFolder.DefaultMessageClass, "IPM.Note") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Bitte wählen Sie einen Ordner für E-Mails aus." _
                , vbCritical + vbOKCancel, "E-Mailordner auswählen") = vbCancel Then
                Exit Function
            End If
        End If
 
    Loop While objFolder Is Nothing
 
    '---------------------------------------------------------------------
    ' Ordner bzw. Nothing zurückgeben
    '---------------------------------------------------------------------
    Set ChooseFolder = objFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function