Outlook-Excel-Outlook
Thomas
ich hab zwei Codes gefunden und angepasst soweit ich konnte aber nun hänge ich bzw. bin mit meinem Wissen am Ende.
Mit dem Einlesen der Outlookkontakte in Excel das funzt soweit bis auf die Formatierung der Telefonnummern gleich im Code. Das zum einen.
Der andere Code schreibt mir die Excelkontakte wieder zurück.
Erstens der Code bringt eine Fehlermeldung bei dem zurückschreiben der Telefon und Mobil Nummer. ( Objekt unterstützt Eigenschaft und Methode nicht.
Zweitens sollte der Code die Kontakte in Outlook erst löschen bevor die neue Kontakte übergeben werden, da ich sonst doppelte einträge habe.
Code zum Einlesen in Excel
~
Sub ContactsToExcel()
'Deklaration
Dim oApp As New Outlook.Application
Dim nspMapi As Outlook.Namespace
Dim folMapi As Outlook.MAPIFolder
Dim itmAll As Outlook.Items
Dim itmReal As Outlook.Items
Dim itmContacts As Outlook.ContactItem
Dim strContactFilter As String
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Integer
'Outlook-Objekte öffnen
Set nspMapi = oApp.GetNamespace("MAPI")
Set folMapi = nspMapi.GetDefaultFolder(olFolderContacts)
Set itmAll = folMapi.Items
'Verteilerlisten herausfiltern,
'nur 'Richtige Kontakte' verwenden
strContactFilter = "[MessageClass] = 'IPM.Contact'"
Set itmReal = itmAll.Restrict(strContactFilter)
'Excel-Objekte öffnen
Set excApp = Excel.Application
Set excWkb = excApp.ThisWorkbook 'Neues Workbook anlegen
Set excWks = excWkb.Sheets(1) 'Erstes Sheet
'Excel-Worksheet aufbereiten
With excWks
'Sheet-Name
.Name = "Kontakte"
'Spaltenüberschriften
.Cells(1, 1).Value = "Vorname"
.Cells(1, 2).Value = "Nachname"
.Cells(1, 3).Value = "Strasse"
.Cells(1, 4).Value = "PLZ"
.Cells(1, 5).Value = "Ort"
.Cells(1, 6).Value = "Telefon"
.Cells(1, 7).Value = "Mobil"
.Cells(1, 8).Value = "eMail"
.Cells(1, 9).Value = "Fax"
.Cells(1, 10).Value = "Tel. geschäftl."
.Cells(1, 11).Value = "Fax geschäftl."
'Spaltenüberschriften fett
.Rows("1:1").Font.Bold = True
'Outlook-Kontakte nach Excel übertragen
intRow = 2
For Each itmContacts In itmReal
.Cells(intRow, 1).Value = itmContacts.FirstName
.Cells(intRow, 2).Value = itmContacts.LastName
.Cells(intRow, 3).Value = itmContacts.HomeAddressStreet
.Cells(intRow, 4).Value = itmContacts.HomeAddressPostalCode
.Cells(intRow, 5).Value = itmContacts.HomeAddressCity
.Cells(intRow, 6).Value = itmContacts.HomeTelephoneNumber 'Formatierung
.Cells(intRow, 7).Value = itmContacts.MobileTelephoneNumber 'Formatierung
.Cells(intRow, 8).Value = itmContacts.Email1Address
.Cells(intRow, 9).Value = itmContacts.HomeFaxNumber 'Formatierung
.Cells(intRow, 10).Value = itmContacts.BusinessTelephoneNumber 'Formatierung
.Cells(intRow, 11).Value = itmContacts.BusinessFaxNumber 'Formatierung
intRow = intRow + 1
Next itmContacts
'Optimale Spaltenbreite
.Columns.AutoFit
End With
'Excel einblenden
excApp.Visible = True
'Speicher freigeben
Set itmReal = Nothing
Set itmAll = Nothing
Set folMapi = Nothing
Set nspMapi = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
End Sub
~Code zum zurück nach Outlook Schreiben
~
Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'Wo stehen die Kontaktdaten
Set qWks = Worksheets("Kontakte")
'Outlook Objekt erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Mit "With" wird auf das Tabellenobjekt referenziert
With qWks
'Zählschleife starten
'Dazu wird der letzten Eintrag in Spalte A bestimmt
'Der Adressenbereich beginn in Zeile 2
'deshalb startet auch die Zählschleife dort
For i = 2 To Range("A65536").End(xlUp).Row
'Outlook Kontaktobject erstellen
Set MyOutCon = MyOutApp.CreateItem(2)
'Eine vollständige Liste der möglichen Felder
'finden Sie in der Outlook-VBA-Hilfe
With MyOutCon
.FirstName = Cells(i, 1).Value 'Name
.LastName = Cells(i, 1).Offset(0, 1).Value 'Nachname
.HomeAddressStreet = Cells(i, 1).Offset(0, 2).Value 'Straße
.HomeAddressPostalCode = Cells(i, 1).Offset(0, 3).Value 'PLZ
.HomeAddressCity = Cells(i, 1).Offset(0, 4).Value 'Ort
'.HomeAddressTelehoneNumber = Cells(i, 1).Offset(0, 5).Value 'Telefon ' _
Fehlermeldung
'.MobileTelehoneNumber = Cells(i, 1).Offset(0, 6).Value 'Mobil ' _
Fehlermeldung
.Email1Address = Cells(i, 1).Offset(0, 7).Value 'eMail
.HomeFaxNumber = Cells(i, 1).Offset(0, 8).Value 'Fax
.BusinessTelephoneNumber = Cells(i, 1).Offset(0, 9).Value 'Tel geschäftl.
.BusinessFaxNumber = Cells(i, 1).Offset(0, 10).Value 'Fax geschäftl.
.Save
End With
'Object entfernen
Set MyOutCon = Nothing
Next i
End With
Set MyOutApp = Nothing
End Sub
~Kann mir bei der Anpassung der Codes helfen? Vielen Dank schon im voraus.
Mit freundlichen Grüßen
Thomas T.