Hi,
...habe nun etwas gebastelt. Es läuft auch, nur es kommt zu folgendem Phänomen:
Beim ersten Export in einen leeren Outlook-Kontaktordner, gibt es wohl schon 1 Kontakt, der aktualisiert wurde.
Bei jedem weiteren Export aller Kontakte in den gleichen Ordner, zeigt er mit an - er hätte ca. 100 Neue und 1200 aktualisiert von 1300 Kontakten.
Warum? Schließlich sind die Kontakte ja stets aus der selben Datei und landen im selben Kontakt-Ordner...
Gruß und Danke!
Kay
Hier mein Code:
' zuvor werden die Kontakte in ein Array aus der Tabelle gelesen (arrK).
' die Defintion der Variablen erfolgt in Option explicit - Bereich oben
'----------------------------------------------------------------
' Start des Exports der Kontakte
' Über alle Einträge des Arrays
u = 0
t = 0
x = 0
booFind = False
' Statusleiste einstellen
objPBStatus.Value = 0
PBMax = UBound(arrKO)
If PBMax = 0 Then PBMax = 1
objPBStatus.Min = 0
objPBStatus.Max = PBMax + 1
' Einträge vorher sortieren (schneller)
Set objItems = objMyFolder.Items
objItems.Sort "[Lastname]", False 'nach Nachname
'Verteilerlisten herausfiltern, nur 'Richtige Kontakte' durchsuchen
strContactFilter = "[MessageClass] = 'IPM.Contact'"
Set itmContacts = objItems.Restrict(strContactFilter)
' Schleife über alle Kontakte im Array
For o = 0 To UBound(arrKO) - 1
' Ermittle alle Kontakte in Outlook, die den gleichen Nachnamen haben
Set itmContacts = objItems.Restrict("[Nachname] = '" & arrKO(o, 3) & "'")
' Prüfe dann bei den ermittelten genauer, ob diese mit dem zu exportierenden identisch sind,
' wenn ja, dann Boofind = Wahr (dann Kontakt aktualisieren)
For Each itmContactsName In itmContacts
With itmContactsName
If (.LastName & .FirstName & .CompanyName) = (arrKO(o, 3) & arrKO(o, 2) & arrKO(o, 5)) Then
booFind = True
Exit For
End If
End With
q = q + 1
Next itmContactsName
' Daten aktualisieren
If booFind Then
With objItems
On Error Resume Next
.Title = arrKO(x, 1)
.FirstName = arrKO(x, 2)
.LastName = arrKO(x, 3)
.JobTitle = arrKO(x, 4)
.CompanyName = arrKO(x, 5)
.Department = arrKO(x, 6)
.BusinessAddressStreet = arrKO(x, 7)
.BusinessAddressPostalCode = arrKO(x, 8)
.BusinessAddressCity = arrKO(x, 9)
.BusinessAddressState = arrKO(x, 10)
.BusinessAddressCountry = arrKO(x, 11)
.BusinessTelephoneNumber = arrKO(x, 12)
.Business2TelephoneNumber = arrKO(x, 13)
.BusinessFaxNumber = arrKO(x, 14)
.MobileTelephoneNumber = arrKO(x, 15)
.Categories = arrKO(x, 16)
.BusinessHomePage = arrKO(x, 17)
.Email1Address = arrKO(x, 18)
' Private Daten
.HomeAddressStreet = arrKO(x, 19)
.HomeAddressPostalCode = arrKO(x, 20)
.HomeAddressCity = arrKO(x, 21)
.HomeAddressCountry = arrKO(x, 22)
.HomeFaxNumber = arrKO(x, 23)
.HomeTelephoneNumber = arrKO(x, 24)
.OtherTelephoneNumber = arrKO(x, 25)
.Email2Address = arrKO(x, 26)
.Birthday = arrKO(x, 27)
If arrKO(x, 28) "" Then .AddPicture (arrKO(x, 28))
' Sonstiges
.Body = arrKO(x, 29)
' Speichern
.Save
End With
booFind = False
u = u + 1
Else
' Kontakt neu anlegen
Set objMyOutCon = objMyFolder.Items.Add(2)
With objMyOutCon
On Error Resume Next
.Title = arrKO(x, 1)
.FirstName = arrKO(x, 2)
.LastName = arrKO(x, 3)
.JobTitle = arrKO(x, 4)
.CompanyName = arrKO(x, 5)
.Department = arrKO(x, 6)
.BusinessAddressStreet = arrKO(x, 7)
.BusinessAddressPostalCode = arrKO(x, 8)
.BusinessAddressCity = arrKO(x, 9)
.BusinessAddressState = arrKO(x, 10)
.BusinessAddressCountry = arrKO(x, 11)
.BusinessTelephoneNumber = arrKO(x, 12)
.Business2TelephoneNumber = arrKO(x, 13)
.BusinessFaxNumber = arrKO(x, 14)
.MobileTelephoneNumber = arrKO(x, 15)
.Categories = arrKO(x, 16)
.BusinessHomePage = arrKO(x, 17)
.Email1Address = arrKO(x, 18)
' Private Daten
.HomeAddressStreet = arrKO(x, 19)
.HomeAddressPostalCode = arrKO(x, 20)
.HomeAddressCity = arrKO(x, 21)
.HomeAddressCountry = arrKO(x, 22)
.HomeFaxNumber = arrKO(x, 23)
.HomeTelephoneNumber = arrKO(x, 24)
.OtherTelephoneNumber = arrKO(x, 25)
.Email2Address = arrKO(x, 26)
If arrKO(x, 27) "" Then .Birthday = arrKO(x, 27)
If arrKO(x, 28) "" Then .AddPicture (arrKO(x, 28))
' Sonstiges
.Body = arrKO(x, 29)
' Speichern
.Save
End With
t = t + 1
Set objMyOutCon = Nothing
Set objOutlook = Nothing
End If
x = x + 1
' Statusleiste Fortschritt anzeigen
objPBStatus.Value = x
Next o
' Temporäre Zuweisungen wieder löschen
Set objNameSpace = Nothing
Set objNameSpace = Nothing
Set objMapiFolder = Nothing
Set objMyFolder = Nothing
Set objItems = Nothing
MsgBox "" & u & " Kontakte wurden aktualisiert." & VBA.Chr(13) & _
VBA.Chr(13) & t & " Kontakte wurden Neu angelegt.", vbOKOnly, "Outlook-Kontakt"
objPBStatus.Visible = False
Ende:
End Sub