Excel==>Outlook (Frage an Bernd, bst).....
25.11.2005 09:43:34
Matthias_FFM
die nachfolgende Routine stammt von Dir, daher dazu auch eine weitere Frage:
Ursprungsproblem war die Abfrage: wenn kein Kontakt in Outlook vorhanden, dann Neuanlage, ansonsten schreibe in den vorhandenen Kontakt, bislang aber nur in den Standard-Ordner.
Bei einem kleinen upgrade von mir in der Funktion 'GetKontakt' prüft die Routine zwar ob der Kontakt (Vorname/Nachname) in einem anderen Ordner =(Varaible) vorhanden ist und stellt korrekt 'NeuerKontakt' auf True (da es sich um einen leeren, neuen Ordner handelt).
Die Routine schreibt aber dann dennoch alle Kontakte in den DefaultFolder und natürlich auch als neuen Kontakt, da ja 'NeuerKontakt' auf 'True' steht.
Nun kenne ich zwar prima mein Problen, komme aber an eine Lösung nicht heran.
Danke für Deine Tipps.....
und viele Grüße aus dem verschneiten FFM
Matthias_FFM
Sub Senden_Kontakte()
Dim qWks As Worksheet
Dim MyOutApp As Object, MyOutCon As Object, NeuerKontakt As Boolean
Dim Postfach As String, Kontakt1 As String, kontakt2 As String
Dim LoI As Integer, i As Integer, y As Integer
'Wo stehen die Kontaktdaten
Set qWks = Worksheets("Kontakte_Export")
Sheets("Kontakte_Export").Select
Range("a1").Select
'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 B bestimmt
'Der Adressenbereich beginn in Zeile 2
'deshalb startet auch die Zählschleife dort
i = 2
For LoI = 2 To Range("A65536").End(xlUp).Row
'Outlook Kontaktobject suchen bzw. neu erstellen
'Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 4).Value, Cells(i, 5).Value)
Set MyOutCon = GetKontakt(MyOutApp, Cells(i, 4).Value, Cells(i, 5).Value, NeuerKontakt)
With MyOutCon
'Einlesen der Kontakte über Schleife
y = 3
Sheets("Kontakte_Export").Select
.Email1Address = Cells(i, y).Value
y = y + 1
.LastName = Cells(i, y).Value
y = y + 1
'etc.
'etc
.Save
End With
'Object entfernen
Set MyOutCon = Nothing
Next LoI
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
Postfach = Range("Tabelle1!a1") ' z. B. Postfach Matthias
Kontakt1 = Range("Tabelle1!a2") 'Kontakte
kontakt2 = Range("Tabelle1!a3") 'Mailing = neuer Ordner, aber schon angelegt....
' öffnet den Standard-Kontaktordner, 10 = olFolderContacts
'Set f = olApp.GetNamespace("MAPI").GetDefaultFolder(10)
Set f = olApp.GetNamespace("MAPI").Folders(Postfach).Folders(Kontakt1).Folders(kontakt2)
'sucht korrekt die Kontakte in z. B. Mailing
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(da neuer Ordner), 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