Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
684to688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
684to688
684to688
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Kontakte von Excel nach Outlook

Kontakte von Excel nach Outlook
21.10.2005 10:18:21
Excel
Guten Morgen Excel Experten,
die nachfolgende Routine exportiert Infos zu Kontakten von Excel nach Outlook. Falls Name/Vorname in Outlook schon angelegt wurden, werden die Datenfelder mit dem Inhalt von Excel überschrieben, ansonsten ein neuer Kontakt angelegt.
Meine Frage:
Wie sollte die Routine aussehen, wenn bei Existenz des Kontaktes (in Outlook) der Inhalt z. B. vom Datenfeld .Body bestehen bleibt und die Infos von Excel an den vorhandenen Text angehängt werden. Bislang wird der Inhalt des jeweiligen Datenfeldes in Outlook "gnadenlos" durch den Text vom Excel-Export ersetzt.
Hier die Routine:

Sub Send_Contact_List()
Dim qWks As Worksheet, i As Integer
Dim MyOutApp As Object, MyOutCon As Object
'by Ramses/überarbeitet von MichaV
Set qWks = Worksheets("Kontakte")
Sheets(1).Select
Set MyOutApp = CreateObject("Outlook.Application")
With qWks
For i = 2 To Range("A65536").End(xlUp).Row
Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 1).Value, Cells(i, 2).Value)
With MyOutCon
.Title = Cells(i, 3).Value
.Email1Address = Cells(i, 4).Value
.MobileTelephoneNumber = Cells(i, 5).Value
.Birthday = Cells(i, 6).Value
.Categories = Cells(i, 7).Value
.HomeAddressStreet = Cells(i, 8).Value
.HomeAddressPostalCode = Cells(i, 9).Value
.HomeAddressCity = Cells(i, 10).Value
.HomeAddressCountry = Cells(i, 11).Value
.HomeAddressState = Cells(i, 12).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

Vielen Dank für Eure Tipps.....
LG Matthias_FFM

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kontakte von Excel nach Outlook
21.10.2005 12:00:51
Excel
Hi Matthias,
versuch mal sowas.
cu, Bernd
--
Option Explicit

Sub Send_Contact_List()
   Dim qWks As Worksheet, i As Integer
   Dim MyOutApp As Object, MyOutCon As Object, NeuerKontakt As Boolean
   
   'by Ramses/überarbeitet von MichaV und bst
   Set qWks = Worksheets("Kontakte")
   Sheets(1).Select
   Set MyOutApp = CreateObject("Outlook.Application")
   With qWks
      For i = 2 To Range("A65536").End(xlUp).Row
         Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 1).Value, Cells(i, 2).Value, NeuerKontakt)
         With MyOutCon
            .Title = Cells(i, 3).Value
            .Email1Address = Cells(i, 4).Value
            .MobileTelephoneNumber = Cells(i, 5).Value
            .Birthday = Cells(i, 6).Value
            .Categories = Cells(i, 7).Value
            .HomeAddressStreet = Cells(i, 8).Value
            .HomeAddressPostalCode = Cells(i, 9).Value
            .HomeAddressCity = Cells(i, 10).Value
            .HomeAddressCountry = Cells(i, 11).Value
            .HomeAddressState = Cells(i, 12).Value
            If NeuerKontakt Then
               .Body = "ICH BIN NEU"
            Else
               .Body = "MICH GAB ES SCHON"
            End If
            .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, NeuerKontakt As Boolean) As Object
   Dim f As Object, item As Object
   
   NeuerKontakt = False
   ' ö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)
   NeuerKontakt = True
   ' Und dann noch die Namen eintragen
   GetKontakt.LastName = LastName
   GetKontakt.FirstName = FirstName
End Function

Anzeige
AW: Kontakte von Excel nach Outlook (noch offen)
21.10.2005 12:52:00
Excel
Hallo Bernd,
vielen Dank für die ersten Ideen, leider noch keine Lösung, da bei Export nach Outlook und Änderung vom Text Datenfeld .Body ein neuer Kontakt angelegt wird, obwohl Nachname und Vorname nicht geändert werden.
Sicher war meine Frage nicht sauber genug formuliert:
1. Bestehender Kontakt in Outlook:
a) .Body wird u.a. nach Excel importiert, dort modifiziert und
aa) bei Export nach Outlook den dortigen Text komplett ersetzen (alte Lösung)
bb) bei Export nach Outlook an den schon vorhandenen Text angehängt (editiert), d.h. um einen Update vom Inhalt .Body vornehmen zu können, müsste nicht unbedingt vorher ein Import von Outlook erfolgt sein.
2. Neuer Kontakt
kein Unterschied zwischen aa) und bb)
Vielen Dank für Eure Unterstützung......
LG Matthias_FFM
Anzeige
AW: Kontakte von Excel nach Outlook (noch offen)
21.10.2005 13:14:22
Excel
Hallo Matthias,
wenn ich's denn richtig verstanden haben sollte ?
ändere die Zeile:
.Body = "MICH GAB ES SCHON"
in sowas ähnliches ab:
.Body = .Body & vbCRLF & "MICH GAB ES SCHON"
cu, Bernd
Danke.....klasse Lösung
21.10.2005 14:19:47
Matthias_FFM
Hallo Bernd,
richtig verstanden und perfekt gelöst.....
Habe meine eingestellte Routine ergänzt um Deinen Vorschlag:
.Body = .Body & vbCRLF & "MICH GAB ES SCHON"
Klasse, Danke und ein schönes Wochenende......
LG Matthias_FFM
OwT: Bitteschön und gleichfalls
21.10.2005 14:35:05
bst
.

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige