Exporteren van Excel naar Outlook

[Ocirne]

Hallo,

Vanuit een Excelbestand wil ik in Outlook contacten aanmaken en daarbij bepaalde items exporteren naar Outlook. Ik heb via internet de navolgende code hiervoor gevonden hetgeen op zich prima werkt. Het probleem is alleen dat steeds als de macro wordt gedraaid alle namen opnieuw worden toegevoegd. Met als gevolg dat reeds bestaande contacten dubbel in Outlook komen te staan. Nu wil ik graag dat als de lijst in Excel wordt uitgebreid met nieuwe namen (en bijbehorende gegevens) alleen van de nieuwe namen een contact wordt aangemaakt als de macro wordt gedraaid. Hoe zou ik de code kunnen aanpassen dat alleen nieuwe namen worden toegevoegd? Ik denk zelf aan het selecteren van de rijen die moeten worden toegevoegd, maar kom er niet uit. Wie kan me helpen?

Sub ExcelWorksheetDataAddToOutlookContacts1()

Dim applOutlook As Outlook.Application
Dim nsOutlook As Outlook.Namespace
Dim ciOutlook As Outlook.ContactItem
Dim delFolder As Outlook.folder
Dim delItems As Outlook.Items
Dim lLastRow As Long, i As Long, n As Long, c As Long

lLastRow = Sheets("Clientgegevens").Cells(Rows.Count, "A").End(xlUp).Row

Set applOutlook = New Outlook.Application
Set nsOutlook = applOutlook.GetNamespace("MAPI")
Set delFolder = nsOutlook.GetDefaultFolder(olFolderDeletedItems)
Set delItems = delFolder.Items

c = delItems.Count
For n = c To 1 Step -1
delItems(n).Delete
Next n

For i = 2 To lLastRow

Set ciOutlook = applOutlook.CreateItem(olContactItem)
ciOutlook.Display
With ciOutlook
.FirstName = Sheets("Clientgegevens").Cells(i, 1)
.LastName = Sheets("Clientgegevens").Cells(i, 2)
.Email1Address = Sheets("Clientgegevens").Cells(i, 3)
.Email1DisplayName = Sheets("Clientgegevens").Cells(i, 4)
.MobileTelephoneNumber = Sheets("Clientgegevens").Cells(i, 5)
.homeaddressstreet = Sheets("Clientgegevens").Cells(i, 6)
.homeaddresspostalcode = Sheets("Clientgegevens").Cells(i, 7)
.homeaddresscity = Sheets("Clientgegevens").Cells(i, 8)
.birthday = Sheets("Clientgegevens").Cells(i, 9)
End With

ciOutlook.Close olSave
Next i

applOutlook.Quit

Set applOutlook = Nothing
Set nsOutlook = Nothing
Set ciOutlook = Nothing
Set delFolder = Nothing
Set delItems = Nothing

End Sub

Alvast bedankt,

Ocirne

 

[OctaFish]

Voordat je de record wegschrijft moet je dus eerst controleren of de persoon al bestaat. Door dus de contactlijst te openen

    Set olFolder = olNamespace.GetDefaultFolder(10)
    Set olConItems = olFolder.Items
    For Each olItem In olConItems
        If TypeName(olItem) = "ContactItem" Then
            With olItem
                If InStr(olItem.CompanyName, strDummy) > 0 Then
                    If .FullName = Sheets("Clientgegevens").Cells(i, 1) & " " & Sheets("Clientgegevens").Cells(i, 2) Then
                        MsgBox "Persoon bestaat al", vbOKOnly
                        Exit Sub
                    End If
                End If
            End With
        End If
    Next olItem

De code is een beetje bij elkaar geraapt, maar daar kun je vast wel iets werkends van maken

 

[Ocirne]

Ik krijg een compileerfout op de regel:

    Set olFolder = olNamespace.GetDefaultFolder(10)

Melding: "ongeldige kwalificatie"

Enig idee waardoor dat wordt veroorzaakt?

 

[Ocirne]

Ik kom helaas niet verder. Is er iemand die nog een alternatief kan bieden? Zelf zou ik het wel handig vinden als de toevoegingen aan de contactenlijst gebeurt op basis van een selectie, maar helaas krijg ik dat niet voor elkaar.

Alvast bedankt.

Mvg,

Ocirne

 

[Warme bakkertje]

Sub ExcelWorksheetDataAddToOutlookContacts1()

Dim ws As Worksheet, lLastRow As Long, i As Long, c00 As String, c01 As String

Set ws = Sheets("Clientgegevens")
lLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

With CreateObject("Outlook.Application")
    For i = 2 To lLastRow
    With .GetNamespace("MAPI").GetDefaultFolder(10).Items
        c00 = ws.Cells(i, 1) & " " & ws.Cells(i, 2)
        For Each it In .Restrict("[FullName]='" & c00 & "'")
            c01 = it.FullName
        Next
    End With
    If c01 = vbNullString Then
        With .CreateItem(2)
            .FirstName = ws.Cells(i, 1)
            .LastName = ws.Cells(i, 2)
            .Email1Address = ws.Cells(i, 3)
            .Email1DisplayName = ws.Cells(i, 4)
            .MobileTelephoneNumber = ws.Cells(i, 5)
            .HomeAddressStreet = ws.Cells(i, 6)
            .HomeAddressPostalCode = ws.Cells(i, 7)
            .HomeAddressCity = ws.Cells(i, 8)
            .Birthday = ws.Cells(i, 9)
            .Close olSave
        End With
    End If
    Next
End With
Set ws = Nothing

End Sub

 

[Ocirne]

Hi Rudi,

Bedankt (jij ook trouwens Octafish) voor de hulp. Helaas nog steeds niet met succes.

Als ik aan mijn excellijst nieuwe namen toevoeg en jouw macro draai dan worden de nieuwe namen niet toegevoegd.

Dus heb ik mijn contactenlijst in Outlook in zijn geheel verwijderd. Als ik dan de macro draai, krijg ik een foutcode op

            .FirstName = ws.Cells(i, 1)

en daarvoor deze foutmelding:


Enig idee wat er misgaat?

Thanks.

Ocirne

 

[Warme bakkertje]

Neen, want als ik mijn naam met alle andere gegevens aan mijn contactlijst probeer toe te voegen werkt de code als een zonnetje.
Je zal dus met iets meer informatie moeten komen, want met de code is er absoluut niets mis.

 

[Ocirne]

Ondanks het zonnetje buiten, loopt het op mijn pc helaas nog niet als een zonnetje.

Ik draai de macro op een PC met Office 2016 (64-bits) en heb het net ook even getest op een pc met Office 2013 (32-bits). Het resultaat is steeds hetzelfde. Ik voeg daarom het bestand toe waarmee ik heb getest. Misschien heb ik daar toch een fout gemaakt. Als dat zo is, zie ik alleen niet waar het misgaat.... Hopelijk kun je me verder helpen nu je deze info hebt.

Bekijk bijlage Adressen e-mail.xlsm

 

[Warme bakkertje]

Zoals al eerder gezegd op XL2007 geen enkel probleem. Twee namen worden toegevoegd.
Doorloop de code eens met de F8 toets en bekijk de resultaten van de verschillende variabelen eens in het venster Lokale Variabelen.
Misschien dat er in die latere versies iets verkeerd loopt, maar dit kan ik niet controleren.

 

[Ocirne]

Hi Rudi,

Ik heb de code doorlopen met F8. Het loopt steeds vast bij de regel:

.FirstName = ws.Cells(i, 1)

In het Lokale Venster krijg ik een hoop gegevens, maar ik weet niet waar ik naar moet kijken om te achterhalen waar het probleem mogelijk zit. Kun je me misschien aangeven waar ik naar op zoek moet?

Mvg,

Ocirne

 

[Warme bakkertje]

Zet een onderbrekingspunt (F9) op de regel with .createitem(2).
De code zal tot daar doorlopen (F5) en nu kan je alle waarden controleren zoals lLastrow, c00, c01.
Als je met de muiswijzer over cells(i,1) wijst kan je ook deze waarde aflezen.
Heb eens rondgekeken maar er lijkt op het eerste zicht toch niets gewijzigd betreffende naamgeving e.d.

 

[Ocirne]

Als ik je stappen volg, krijg ik:
: lLastRow : 3 : Long
: i : 2 : Long
: c00 : "Jan Klaassen" : String
: c01 : "" : String

En nog een hele waslijst onder ws als ik dat openklap.

Helpt je dit verder? Ik heb op basis van reacties op mijn foutcode op andere fora nog suggesties gehad om code toe te voegen die expliciet verwijzen naar mijn Office versie. Maar ook dat is zonder resultaat.

Zelf dacht ik aan het vervangen van 'i' in mijn code door selectedrows maar daar kom ik helaas ook niet verder mee.

Nog ideeën?

Mvg,

Ocirne

 

[Warme bakkertje]

Zorg dat er minstens 1 contact in je contactlijst zit en draai dan eens onderstaande.

Sub tst()
With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10).Items(1)
    MsgBox .FirstName
End With
End Sub

 

[Ocirne]

Uitgevoerd.

Ik krijg dan de voornaam van het contact dat aanwezig is in Outlook

 

[Warme bakkertje]

En wat doet deze ?

Sub tst()
With CreateObject("Outlook.Application").CreateItem(2)
     .FirstName = "Ocirne"
     .Close olSave
End With
End Sub

Ik probeer maar alle mogelijkheden uit .....

 

[Ocirne]

"Ocirne" wordt toegevoegd aan contactenlijst Outlook...

 

[Warme bakkertje]

Deze werkt bij mij ook. Als deze het bij jou niet doet geef ik het officieel op want alle variabelen die jij hebt doorgegeven kloppen, hij herkent ws.cells(i,1) eerder in de macro, CreateItem(2).FirstName herkent hij ook (en werkt afzonderlijk).

Sub ExcelWorksheetDataAddToOutlookContacts()

Dim ws As Worksheet, lLastRow As Long, i As Long, c00 As String, c01 As String

Set ws = Sheets("Clientgegevens")
lLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To lLastRow
    With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10).Items
        c00 = ws.Cells(i, 1) & " " & ws.Cells(i, 2)
        For Each it In .Restrict("[FullName]='" & c00 & "'")
            c01 = it.FullName
        Next
    End With
    If c01 = vbNullString Then
        With CreateObject("Outlook.Application").CreateItem(2)
            .FirstName = ws.Cells(i, 1)
            .LastName = ws.Cells(i, 2)
            .Email1Address = ws.Cells(i, 3)
            .Email1DisplayName = ws.Cells(i, 4)
    '        .MobileTelephoneNumber = ws.Cells(i, 5)
    '        .HomeAddressStreet = ws.Cells(i, 6)
    '        .HomeAddressPostalCode = ws.Cells(i, 7)
    '        .HomeAddressCity = ws.Cells(i, 8)
    '        .Birthday = ws.Cells(i, 9)
            .Close 0
        End With
    End If
Next
Set ws = Nothing

End Sub

 

[Ocirne]

Jammer, Rudi. Uiteraard heel erg bedankt voor je tijd en moeite!!

Misschien zijn er nog andere forumleden die hier een slinger aan kunnen geven? Ik zou er heel blij mee zijn...

 

[Warme bakkertje]

Ik mag dus aannemen dat de code uit post #17 ook niet werkt ?
En met deze ?

.FirstName = ws.Cells(i, 1).Value

 

[Ocirne]

Inderdaad, Rudi. De code in #17 werkt niet.

Even werd ik blij toen ik merkte dat aanpassing met

.value

de volgende regel dezelfde foutcode opleverde. Alle vier de regels aangepast en vervolgens werden de twee contacten keurig toegevoegd aan Outlook.

Echter, nadat ik in Excel een nieuwe naam/regel opvoerde en de macro draaide, gebeurde er helemaal niets. Het lijkt bijna of de code voor eenmalig gebruik is.....