probleme mit adress-übertragung
25.03.2007 21:10:52
Marko
mit folgenem code füge ich meine adressen von einer exelliste in die outlook kontakte ein!
es werden immer nur die adressen eingefügt die neu dazu gekommen sind, da ist mir allerdings gerade ein sehr blödes problem aufgefallen.... er erstellt zwar keine neue kontaktkarte falls der name schon vorhanden ist aber im kalender schreibt er jedesmal wieder die geburtstage rein..... also hat man die anzeige des geburtstages dann doppelt und dreifach nach mehreren aktualisierungen!
kann mir einer sagen was da nun verkehrt läuft?
Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
Set qWks = Worksheets("Adressen")
Sheets(1).Select
Set MyOutApp = CreateObject("Outlook.Application")
With qWks
For i = 5 To Range("A65536").End(xlUp).Row
Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 2).Value, Cells(i, 1).Value)
With MyOutCon
.Email1Address = Cells(i, 15).Value
.HomeTelephoneNumber = Cells(i, 8).Value
.Birthday = Cells(i, 9).Value
.Categories = Cells(i, 4).Value
.HomeAddressStreet = Cells(i, 5).Value
.HomeAddressPostalCode = Cells(i, 6).Value
.HomeAddressCity = Cells(i, 7).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