Hilfe, hier stimmt was nicht! Out-Kontakt-Export
KLE
...ich komme nicht weiter und brauch dringend eure Hilfe!
Ich habe ein Liste in Excel mit Kontaktdaten. DIese möchte ich gern als Kontakte in mein Outlook exportieren.
Dafür nutze ich den unten stehenden Code.
Es funktioniert perfekt, wenn es darum geht - Kontakte in einen neuen Ordner zu packen im Outlook. Aber wenn da schon Kontakte drin stehen - arbeitet er zwar, aber in Outlook werden KEINE Kontakte angelegt?
Es ist sogar so, dass z.B. bei einem Export von 1000 Kontakten in einen Out-Kontakt-Ordner, wo 20 bereits drin sind - das Tool am Ende zwar sagt, es habe 1000 aktualisiert - aber in Outlook immer noch nur die 20 stehen?!?
Es muss also im Code ein Fehler sein, bei der Prüfung ob ein Kontakt schon drin steht oder nicht. Denn Excel scheint ja alle 1000 in dem Ordner mit 20 gefunden zu haben ?!? WIe sonst kann er sie alle aktualisiert haben ?!?
Leider habe ich keine Ahnung, woran es liegen könnte...daher brauche ich EURE Hilfe, muss es bis morgen Früh behoben haben - sagt Cheffe!!!
Vielen Dank und Gruß an Euch alle, meine Helden des Forums ;o)
Kay
Hier der Code aus der Userform, wo der User die Kontakte auswählen kann, welche exportiert werden sollen:
' ausgewählte Kontakte als Outlook-Kontaktkarte speichern/nach Outlook exportieren
Private Sub Out2Export()
Dim objNameSpace As Object
Dim objMyFolder
Dim objMapiFolder
Dim objItems
Dim objMyOutCon
Dim booFind As Boolean
Dim strBody As String
' Frage an User
antwort = MsgBox("Alle ausgewählten Kontakte nach Outlook exportieren!", vbYesNo, "Outlook- _
Export")
If antwort = vbNo Then Exit Sub
' Daten aus arrKO in einzelne Kontakte übertragen
' Outlook-Ordner definieren / User trifft Entscheidung per Abfrage
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objMapiFolder = objNameSpace.GetDefaultFolder(10)
Set objMyFolder = olMAPI.GetNamespace("MAPI").PickFolder() ' User sucht den Ordner in Outlook _
_
_
selbst aus.
Set objItems = objMapiFolder.Items
If objMyFolder Is Nothing Then GoTo Ende
' Schleife über alle ausgewählten Kontakte - um alle Infos in ein Array zu packen
With wksDBK
k = UBound(arrK())
ReDim arrKO(k, 29)
If k = 0 Then
MsgBox "Für diesen Export, liegen keine Kontakt-Zuordnungen vor!", vbOKOnly, "Leerer _
Export"
GoTo Ende
Else
x = 0
i = 0
a = 0
z = 0
m = 0
O = 0
p = 0
' Statusleiste einstellen
PBMax = k
If PBMax = 0 Then PBMax = 1
objPBStatus.Min = 0
objPBStatus.Max = PBMax
'Datenarray für Listeneinträge aus DBK
For m = 0 To k - 1 ' alle KIDs
txtKID = arrK(m) ' auslesen des KIDs
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Suche in DBK
If .Cells(i, 2).Value = VBA.CDbl(txtKID) Then
'ReDim Preserve arrKO(1 To x, 29) ' Outlook-Kontakte einlesen incl. aller Daten
arrKO(x, 0) = .Cells(i, 2).Value ' KID
arrKO(x, 1) = .Cells(i, 4).Value ' Title
arrKO(x, 2) = .Cells(i, 7).Value ' FirstName
arrKO(x, 3) = .Cells(i, 8).Value ' LastName
arrKO(x, 4) = .Cells(i, 5).Value ' JobTitle
arrKO(x, 5) = .Cells(i, 10).Value ' CompanyName
arrKO(x, 6) = .Cells(i, 6).Value ' Department
arrKO(x, 7) = .Cells(i, 12).Value '.BusinessAddressStreet
arrKO(x, 8) = .Cells(i, 15).Value '.BusinessAddressPostalCode
arrKO(x, 9) = .Cells(i, 16).Value '.BusinessAddressCity
' ZI - info
y = 0
For y = 2 To wksDBZI.Cells(Rows.Count, 1).End(xlUp).Row
If wksDBZI.Cells(y, 3).Value = VBA.CDbl(txtKID) Then
arrKO(x, 10) = wksDBZI.Cells(y, 19).Value '.BusinessAddressState
GoTo Stepp2
End If
Next y
Stepp2:
arrKO(x, 11) = .Cells(i, 14).Value '.BusinessAddressCountry
arrKO(x, 12) = .Cells(i, 17).Value '.BusinessTelephoneNumber
arrKO(x, 13) = .Cells(i, 18).Value '.Business2TelephoneNumber
arrKO(x, 14) = .Cells(i, 21).Value '.BusinessFaxNumber
arrKO(x, 15) = .Cells(i, 19).Value '.MobileTelephoneNumber
arrKO(x, 16) = "Firmen-Kontakt" '.Categories
arrKO(x, 17) = .Cells(i, 24).Value '.BusinessHomePage
arrKO(x, 18) = .Cells(i, 23).Value '.Email1Address
arrKO(x, 19) = .Cells(i, 9).Value '.Birthday
' Privat-Info
e = 0
For e = 2 To wksDBP.Cells(Rows.Count, 1).End(xlUp).Row
If wksDBP.Cells(e, 3).Value = VBA.CDbl(txtKID) Then
arrKO(x, 20) = wksDBP.Cells(i, 4).Value '.HomeAddressStreet = _
objTBPStrasse.Text
arrKO(x, 21) = wksDBP.Cells(i, 7).Value '.HomeAddressPostalCode = _
_
_
objTBPPLZ.Text
arrKO(x, 22) = wksDBP.Cells(i, 8).Value '.HomeAddressCity = _
objTBPOrt.Text
arrKO(x, 23) = wksDBP.Cells(i, 6).Value '.HomeAddressCountry = _
objTBPLand.Text
arrKO(x, 24) = wksDBP.Cells(i, 11).Value '.HomeFaxNumber = objTBPFax. _
_
_
Text
arrKO(x, 25) = wksDBP.Cells(i, 9).Value '.HomeTelephoneNumber = _
objTBPTel.Text
arrKO(x, 26) = wksDBP.Cells(i, 10).Value '.OtherTelephoneNumber = _
objTBPMob.Text
arrKO(x, 27) = wksDBP.Cells(i, 12).Value '.Email2Address = _
objTBPEmail.Text
arrKO(x, 28) = wksDBP.Cells(i, 14).Value '.AddPicture (objLPPfad. _
Caption)
' Sonstiger Platzhalter (Body)
arrKO(x, 29) = "" '.Body = strBody
GoTo Stepp3
End If
Next e
Stepp3:
x = x + 1
' Statusleiste anzeigen
objPBStatus.Value = x
GoTo Stepp4
End If
Next i
Stepp4:
Next m
End If
End With
' Start des Exports / Ablegen, Bearbeiten der Kontakte
' Über alle Einträge des Arrays
u = 0
t = 0
x = 0
For O = 0 To UBound(arrKO) - 1
' Statusleiste einstellen
PBMax = O
If PBMax = 0 Then PBMax = 1
objPBStatus.Min = 0
objPBStatus.Max = PBMax + 1
Set objItems = objMyFolder.Items
' Einträge vorher sortieren (schneller)
objItems.Sort "[Name]"
objItems.IncludeRecurrences = True
' Prüfen, ob Datensatz schon vorhanden, Wenn ja - Bearbeiten, sonst Neu erstellen
' Code von Tino
Set objItems = objItems.Restrict("[Nachname] = '" & arrKO(O, 3) & "'")
'Schleife durch alle Kontakte bis Vor und Nachname und Firma übereinstimmen
For Each objItems In objItems
With objItems
If (.LastName & .FirstName & .CompanyName) = (arrKO(O, 3) & arrKO(O, 2) & arrKO(O, 5)) _
_
_
Then
booFind = True
Exit For
End If
End With
Next objItems
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
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)
.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 anzeigen
objPBStatus.Value = x
Next O
' Temporäre Zuweisungen wieder löschen
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