die nachfolgende Routine exportiert Infos zu Kontakten von Excel nach Outlook. Falls Name/Vorname in Outlook schon angelegt wurden, werden die Datenfelder mit dem Inhalt von Excel überschrieben, ansonsten ein neuer Kontakt angelegt.
Meine Frage:
Wie sollte die Routine aussehen, wenn bei Existenz des Kontaktes (in Outlook) der Inhalt z. B. vom Datenfeld .Body bestehen bleibt und die Infos von Excel an den vorhandenen Text angehängt werden. Bislang wird der Inhalt des jeweiligen Datenfeldes in Outlook "gnadenlos" durch den Text vom Excel-Export ersetzt.
Hier die Routine:
Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'by Ramses/überarbeitet von MichaV
Set qWks = Worksheets("Kontakte")
Sheets(1).Select
Set MyOutApp = CreateObject("Outlook.Application")
With qWks
For i = 2 To Range("A65536").End(xlUp).Row
Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 1).Value, Cells(i, 2).Value)
With MyOutCon
.Title = Cells(i, 3).Value
.Email1Address = Cells(i, 4).Value
.MobileTelephoneNumber = Cells(i, 5).Value
.Birthday = Cells(i, 6).Value
.Categories = Cells(i, 7).Value
.HomeAddressStreet = Cells(i, 8).Value
.HomeAddressPostalCode = Cells(i, 9).Value
.HomeAddressCity = Cells(i, 10).Value
.HomeAddressCountry = Cells(i, 11).Value
.HomeAddressState = Cells(i, 12).Value
.Save
End With
Set MyOutCon = Nothing
Next i
End With
Set MyOutApp = Nothing
End Sub
Function GetKontakt(OlApp As Object, LastName As String, FirstName As String) As Object
Dim f As Object, item As Object
' öffnet den Standard-Kontaktordner, 10 = olFolderContacts
Set f = OlApp.GetNamespace("MAPI").GetDefaultFolder(10)
' durchsucht dort alle Kontakte
For Each item In f.Items
' Falls Vor- und Nachname übereinstimmen wird dieser Kontakt zurückgegeben
If UCase(item.LastName) = UCase(LastName) And UCase(item.FirstName) = UCase(FirstName) Then
Set GetKontakt = item
Exit Function
End If
Next
' Kein passender Kontakt gefunden, einen neuen Kontakt erstellen
Set GetKontakt = OlApp.CreateItem(2)
' Und dann noch die Namen eintragen
GetKontakt.LastName = LastName
GetKontakt.FirstName = FirstName
End Function
Vielen Dank für Eure Tipps.....
LG Matthias_FFM