Outlook-Kontaktdaten in Excel importieren - LZF 13
01.01.2017 14:55:02
MichaelP
Ich habe hier eine Makro von Ramses
http://www.office.gmxhome.de/_excel_outlook.htm
für meine Zwecke editiert (es geht im weiteren um Datenabgleich mit Fremddaten):
Sub TEST_Read_Contact_from_Outlook()
'by Ramses
'Liest alle Kontakte aus Outlook in das aktuelle Tabellenblatt
Dim myOlk As Object
Dim myOlkContact As Object
Set myOlk = CreateObject("outlook.application")
Set myOlkContact = myOlk.CreateItem(2)
'ALTERCODE: Set myOlkContact = myOlk.CreateItem(olContactItem)
Range("A2").Select
For Each myOlkContact In myOlk.GetNamespace("MAPI").GetDefaultFolder(10).Items
'ALTERCODE: For Each myOlkContact In myOlk.GetNamespace("MAPI").GetDefaultFolder( _
olFolderContacts).Items
With myOlkContact
ActiveCell.Value = .Title ' Anrede
ActiveCell.Offset(0, 1).Value = .FirstName ' Vorname
ActiveCell.Offset(0, 2).Value = .MiddleName ' WeitereVornamen
ActiveCell.Offset(0, 3).Value = .LastName ' Nachname
ActiveCell.Offset(0, 4).Value = .Suffix ' Suffix
ActiveCell.Offset(0, 5).Value = .Companies ' Firma
ActiveCell.Offset(0, 6).Value = .Department ' Abteilung
ActiveCell.Offset(0, 7).Value = .JobTitle ' Position
ActiveCell.Offset(0, 8).Value = .BusinessAddressStreet ' Straßegeschäftlich
'ActiveCell.Offset(0, 9).Value = .Business2AddressStreet ' Straßegeschäftlich2
'ActiveCell.Offset(0, 10).Value = .Business3AddressStreet ' Straßegeschäftlich3
ActiveCell.Offset(0, 11).Value = .BusinessAddressCity ' Ortgeschäftlich
ActiveCell.Offset(0, 12).Value = .BusinessAddressState ' Regiongeschäftlich
ActiveCell.Offset(0, 13).Value = .BusinessAddressPostalCode ' Postleitzahlgeschäftlich
ActiveCell.Offset(0, 14).Value = .BusinessAddressCountry ' LandRegiongeschäftlich
ActiveCell.Offset(0, 15).Value = .HomeAddressStreet ' Straßeprivat
'ActiveCell.Offset(0, 16).Value = .Home2AddressStreet ' Straßeprivat2
'ActiveCell.Offset(0, 17).Value = .Home3AddressStreet ' Straßeprivat3
ActiveCell.Offset(0, 18).Value = .HomeAddressCity ' Ortprivat
ActiveCell.Offset(0, 19).Value = .HomeAddressState ' BundeslandKantonprivat
ActiveCell.Offset(0, 20).Value = .HomeAddressPostalCode ' Postleitzahlprivat
ActiveCell.Offset(0, 21).Value = .HomeAddressCountry ' LandRegionprivat
ActiveCell.Offset(0, 22).Value = .OtherAddressStreet ' WeitereStraße
'ActiveCell.Offset(0, 23).Value = .Other2AddressStreet ' WeitereStraße2
'ActiveCell.Offset(0, 24).Value = .Other3AddressStreet ' WeitereStraße3
ActiveCell.Offset(0, 25).Value = .OtherAddressCity ' WeitererOrt
ActiveCell.Offset(0, 26).Value = .OtherAddressState ' WeiteresrBundeslandKanton
ActiveCell.Offset(0, 27).Value = .OtherAddressPostalCode ' WeiterePostleitzahl
ActiveCell.Offset(0, 28).Value = .OtherAddressCountry ' WeitereseLandRegion
ActiveCell.Offset(0, 29).Value = .AssistantTelephoneNumber ' TelefonAssistent
ActiveCell.Offset(0, 30).Value = .BusinessFaxNumber ' Faxgeschäftlich
ActiveCell.Offset(0, 31).Value = .BusinessTelephoneNumber ' Telefongeschäftlich
ActiveCell.Offset(0, 32).Value = .Business2TelephoneNumber ' Telefongeschäftlich2
ActiveCell.Offset(0, 33).Value = .CallbackTelephoneNumber ' Rückmeldung
ActiveCell.Offset(0, 34).Value = .CarTelephoneNumber ' Autotelefon
ActiveCell.Offset(0, 35).Value = .CompanyMainTelephoneNumber ' TelefonFirma
ActiveCell.Offset(0, 36).Value = .HomeFaxNumber ' Faxprivat
ActiveCell.Offset(0, 37).Value = .HomeTelephoneNumber ' Telefonprivat
ActiveCell.Offset(0, 38).Value = .Home2TelephoneNumber ' Telefonprivat2
ActiveCell.Offset(0, 39).Value = .ISDNNumber ' ISDN
ActiveCell.Offset(0, 40).Value = .MobileTelephoneNumber ' Mobiltelefon
ActiveCell.Offset(0, 41).Value = .OtherFaxNumber ' WeiteresFax
ActiveCell.Offset(0, 42).Value = .OtherTelephoneNumber ' WeiteresTelefon
ActiveCell.Offset(0, 43).Value = .PagerNumber ' Pager
ActiveCell.Offset(0, 44).Value = .PrimaryTelephoneNumber ' Haupttelefon
'ActiveCell.Offset(0, 45).Value = .Mobile2TelephoneNumber ' Mobiltelefon2
'ActiveCell.Offset(0, 46).Value = 'KEINE Objektmodell bekannt ' TelefonfürHörbehinderte
ActiveCell.Offset(0, 47).Value = .TelexNumber ' Telex
ActiveCell.Offset(0, 48).Value = .BillingInformation ' Abrechnungsinformation
ActiveCell.Offset(0, 49).Value = .User1 ' Benutzer1
ActiveCell.Offset(0, 50).Value = .User2 ' Benutzer2
ActiveCell.Offset(0, 51).Value = .User3 ' Benutzer3
ActiveCell.Offset(0, 52).Value = .User4 ' Benutzer4
ActiveCell.Offset(0, 53).Value = .Profession ' Beruf
ActiveCell.Offset(0, 54).Value = .OfficeLocation ' Büro
ActiveCell.Offset(0, 55).Value = .Email1Address ' EMailAdresse
ActiveCell.Offset(0, 56).Value = .Email1AddressType ' EMailTyp
ActiveCell.Offset(0, 57).Value = .Email1DisplayName ' EMailAngezeigterName
ActiveCell.Offset(0, 58).Value = .Email2Address ' EMail2Adresse
ActiveCell.Offset(0, 59).Value = .Email2AddressType ' EMail2Typ
ActiveCell.Offset(0, 60).Value = .Email2DisplayName ' EMail2AngezeigterName
ActiveCell.Offset(0, 61).Value = .Email3Address ' EMail3Adresse
ActiveCell.Offset(0, 62).Value = .Email3AddressType ' EMail3Typ
ActiveCell.Offset(0, 63).Value = .Email3DisplayName ' EMail3AngezeigterName
ActiveCell.Offset(0, 64).Value = .ReferredBy ' Empfohlenvon
ActiveCell.Offset(0, 65).Value = .Birthday ' Geburtstag
ActiveCell.Offset(0, 66).Value = .Gender ' Geschlecht
ActiveCell.Offset(0, 67).Value = .Hobby ' Hobby
ActiveCell.Offset(0, 68).Value = .Initials ' Initialen
ActiveCell.Offset(0, 69).Value = .InternetFreeBusyAddress ' InternetFreiGebucht
ActiveCell.Offset(0, 70).Value = .Anniversary ' Jahrestag
ActiveCell.Offset(0, 71).Value = .Categories ' Kategorien
ActiveCell.Offset(0, 72).Value = .Children ' Kinder
ActiveCell.Offset(0, 73).Value = .Account ' Konto
ActiveCell.Offset(0, 74).Value = .AssistantName ' NameAssistent
ActiveCell.Offset(0, 75).Value = .ManagerName ' NamedesderVorgesetzten
ActiveCell.Offset(0, 76).Value = .body ' Notizen
ActiveCell.Offset(0, 77).Value = .OrganizationalIDNumber ' Organisationsnr
'ActiveCell.Offset(0, 78).Value = .Location ' Ort
ActiveCell.Offset(0, 79).Value = .Spouse ' Partner
ActiveCell.Offset(0, 80).Value = .BusinessAddressPostOfficeBox ' Postfachgeschäftlich
ActiveCell.Offset(0, 81).Value = .HomeAddressPostOfficeBox ' Postfachprivat
ActiveCell.Offset(0, 82).Value = .Importance ' Priorität
ActiveCell.Offset(0, 83).Value = .Sensitivity ' Privat
ActiveCell.Offset(0, 84).Value = .GovernmentIDNumber ' Regierungsnr
ActiveCell.Offset(0, 85).Value = .Mileage ' Reisekilometer
ActiveCell.Offset(0, 86).Value = .Language ' Sprache
'ActiveCell.Offset(0, 87).Value = 'KEINE Objektmodell bekannt ' Stichwörter
ActiveCell.Offset(0, 88).Value = .Sensitivity ' Vertraulichkeit
'ActiveCell.Offset(0, 89).Value = 'KEINE Objektmodell bekannt ' Verzeichnisserver
ActiveCell.Offset(0, 90).Value = .WebPage ' Webseite
ActiveCell.Offset(0, 91).Value = .OtherAddressPostOfficeBox ' WeiteresPostfach
End With
ActiveCell.Offset(1, 0).Select
Next
Set myOlkContact = Nothing
Set myOlk = Nothing
End Sub
Es funktioniert ja alles wunderbar - bis nach der 130. die Übernahme mit dem Laufzeitfehler 138 streikt :-(
Ich habe deshalb die vorhergehenden und nachfolgenden Kontakte mal testweise entfernt - aber es hilft nichts: Er springt nach der Fehlermeldung in der VBA zu
ActiveCell.Value = .Title ' Anrede
... und bleibt stehen.
Bin kein VBA-Profi und komme jetzt nicht klar. Seht Ihr eine Möglichkeit, das Ding zum Laufen zu bringen? Ich habe über 500 Outlook-Kontaktdaten.
Danke und Gruß
Michael