Mehrere Kontakte gleichzeitig ändern

Firma ändern

Wenn Sie zwei Kontakte in der gleichen Firma haben, dann speichert Outlook z.B. den Firmennamen auch zweimal. Das merken Sie spätestens dann, wenn sich dieser ändert: Dann müssen Sie die Änderungen für jeden Kontakt in der Firma einzeln vornehmen.

Das folgende Beispiel nimmt Ihnen diese Arbeit ab, funktioniert aber erst ab Outlook XP. Wenn Sie alle Kontakte der Firma gefunden haben, können Sie natürlich auch andere Eigenschaften, z.B. E-Mail-Adressen, ändern.

  So fügen Sie Makros in Outlook ein

Public Sub ChangeCompanyName()
  Dim sSearch As String
  Dim sFolder As String

  sFolder = "Kontakte"

  sSearch = InputBox("Firma:")
  If Len(sSearch) Then
    sSearch = "urn:schemas:contacts:o = '" & sSearch & "'"
    Application.AdvancedSearch sFolder, sSearch
  End If
End Sub

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Outlook.Search)
  If SearchObject.Results.Count Then
    ChangeNames SearchObject.Results
  End If
End Sub

Private Sub ChangeNames(Results As Outlook.Results)
  Dim obj As Object
  Dim oContact As Outlook.ContactItem
  Dim sNew As String
  Dim i As Long
  
  sNew = InputBox("Neuer Name:")
  If Len(sNew) Then
    For i = Results.Count To 1 Step -1
      Set obj = Results(i)
      If TypeOf obj Is Outlook.ContactItem Then
        Set oContact = obj
        oContact.CompanyName = sNew
        oContact.Save
      End If
    Next
  End If
End Sub

Domain in Emailadresse ändern

Dieses Beispiel ersetzt bei allen Kontakten des aktuellen Ordners einen Teil der Emailadresse durch einen anderen. In der Variable 'Find' steht der zu suchende Teil, in 'ReplaceBy' der neue Wert.

Public Sub ChangeDomainInEmailAddresses()
  Dim Items As Outlook.Items
  Dim Contact As Outlook.ContactItem
  Dim obj As Object
  Dim Find As String
  Dim ReplaceBy As String
  
  Find = "@domain.de"
  ReplaceBy = "@domain.com"
  
  Set Items = Application.ActiveExplorer.CurrentFolder.Items
  For Each obj In Items
    If TypeOf obj Is Outlook.ContactItem Then
      Set Contact = obj
      If InStr(1, Contact.Email1Address, Find, vbTextCompare) Then
        Contact.Email1Address = Replace(Contact.Email1Address, Find, ReplaceBy, , , vbTextCompare)
        Contact.Save
      End If
    End If
  Next
End Sub