Suchen und Ersetzen in Terminen

Mit diesem Beispiel können Sie relativ einfach in Terminen Suchen und Ersetzen (im Betreff oder im Text).

Das Programm fragt alle Parameter ab und gibt am Ende eine Meldung mit der Anzahl der Ersetzungen im Betreff oder im Text 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 Terminen (Betreff oder Text)
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2009-07-26 Version 1.0.0
    '=====================================================================
 
    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 Text 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)
 
    '---------------------------------------------------------------------
    ' Kalender 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
 
            '-------------------------------------------------------------
            ' Enthält die Nachricht den gesuchten Begriff?
            '-------------------------------------------------------------
            If InStr(objItem.Body, strSearch) Then
 
                '---------------------------------------------------------
                ' Text ersetzen
                '---------------------------------------------------------
                objItem.Body = Replace(objItem.Body, strSearch, strReplace)
 
                '---------------------------------------------------------
                ' Änderung speichern
                '---------------------------------------------------------
                objItem.Save
 
                '---------------------------------------------------------
                ' Zähler erhöhen
                '---------------------------------------------------------
                lngReplace = lngReplace + 1
 
            End If
 
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer
    '---------------------------------------------------------------------
    If blnSubject Then
        MsgBox "Ersetzungen im Betreff: " & lngReplace, _
            vbInformation, "Suchen und Ersetzen"
    Else
        MsgBox "Ersetzungen im Text: " & 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 Kalender zurück
    ' 2009-07-26 Version 1.0.0
    '=====================================================================
 
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Hinweis anzeigen
    '---------------------------------------------------------------------
    If MsgBox("Bitte wählen Sie im nächsten Dialog den" & vbCrLf & _
        "zu bearbeitenden Kalender 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.Appointment") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Bitte wählen Sie einen Kalender aus." _
                , vbCritical + vbOKCancel, "Kalender 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