Outlook contactgegevens in excel op een specifieke sheet importeren via VBA code

[Martijn Kist]

Hallo VBA Liefhebbers,

Ik heb momenteel uitgevonden hoe ik outlook contactgegevens (full name) in een combobox geimporteerd krijg, maar ik kwam er achter dat dat heel veel lege "regels" oplevert. Dat en het feit dat er echt helemaal geen volgorde in de namen zit doet mij toekomen aan de bovenstaande vraag.

Ik wil graag middels VBA code contactgegevens importeren op een specifieke sheet, het gaat hierbij eigenlijk alleen om voor-, achternaam en emailadres. Nu heb ik van alles geprobeerd om aanpassingen te maken aan de code die ik heb, maar helaas nog steeds zonder enig succes.

Is er iemand die een opzetje en/of voorbeeld kan geven om het bovenstaande mogelijk te maken.

Ik zou het erg op prijs stellen.

Alvast bedankt.

Mvrgr Martijn

 

[pasan]

omdat ikzelf ook erg benieuwd ben heb ik geprobeerd iets in elkaar te flansen.
van deze site heb ik de code
maar hier ging elke naam in een msgbox en dus ben ik gaan proberen om het onderelkaar in een kolom te krijgen.
De code is niet snel dus ik hoop dat iemand het kan aanpassen (ik heb geprobeerd met een array maar daar heb ik al helemaal geen kaas van gegeten)

zoals je ook op de site leest moet je in je vba editor onder extra dan verwijzingen microsoft outlook object library aanvinken
bij mij werkt de code ook als outlook niet geopend is

Sub Outlook_gegevens_ophalen()

Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")
Set myNameSpace = OutApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set mycontacts = myFolder.Items

For Each myContact In mycontacts
i = i + 1
 Worksheets("Blad1").Range("A" & i) = myContact.FullName  'defineer hier je eigen werkblad
 Worksheets("Blad1").Range("B" & i) = myContact.Email1Address  'ook hier je eigen werkblad kiezen
Next

End Sub

 

[Martijn Kist]

Hallo Pasan,

Ik wil je eerst bedanken voor je moeite en ik ga het proberen!
Dat aanvinken waar jij het over hebt heb ik ook gedaan, waarschijnlijk hebben we dat bij dezelfde persoon gelezen. De code die ik van die persoon had gaf ook alleen messageboxen. Erg vervelend als je meer dan 100 mensen in je Outlook contacts hebt! :d

Nogmaals bedankt alvast

 

[pasan]

de link van die site staat wel in mn bericht boven

 

[Martijn Kist]

Yep dat is em!

Uitgeprobeerd en toch maar niet gebruikt! Hahaha.

Mijn aanpassing skills zijn nog niet zo goed, zeg maar!!

 

[Martijn Kist]

Hi Pasan,

Ik heb de code geprobeerd en het werkt perfect in de nederlandse versie van Excel (helemaal bedankt dus), maar op mijn werk (Engelse versie) krijg ik een foutcode 438, "Object doesn't support this property or method".

Ik moet voor de volledigheid vertellen dat ik op mijn werk ook een "global adresslist" heb, ik had ergens gelezen dat dat nog wel eens problemen oplevert... of is daar ook een workaround voor??

In het onderstaande zie je mijn volledige code, het rode gedeelte is hetgene wat geel gearceerd wordt als ik op debug klik.

Private Sub cmdrenewadressbook_Click()
Dim i As Integer

Set OutApp = CreateObject("Outlook.Application")
Set myNameSpace = OutApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set mycontacts = myFolder.Items

For Each myContact In mycontacts
i = i + 1
 [COLOR="#FF0000"]Worksheets("Adressbook").Range("A" & i) = myContact.FullName  'defineer hier je eigen werkblad[/COLOR]
 Worksheets("Adressbook").Range("B" & i) = myContact.Email1Address  'ook hier je eigen werkblad kiezen
 Worksheets("Adressbook").Range("C" & i) = myContact.Email2Address
 Worksheets("Adressbook").Range("D" & i) = myContact.Email3Address
Next

'Sorteeerd de adressen in sheet Adressbook
    ActiveWorkbook.Worksheets("Adressbook").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Adressbook").Sort.SortFields.Add Key:=Range( _
        "A1:A10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Adressbook").Sort
        .SetRange Range("A1:D10000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Past de kolommen A-D van worksheet aan breedte van de invoer aan
Worksheets("Adressbook").Columns("A:D").AutoFit

Unload Me
frmmainmenu.Show

End Sub

Heeft iemand een idee wat het probleem zou kunnen zijn??

Alvast bedankt.

Mvrgr Martijn

 

[Martijn Kist]

Heb het nog eens geprobeerd.

De code doet eerst 5 namen wel en daarna geeft het die foutcode, echt vreemd.

 

[Martijn Kist]

Oke heb het gevonden.
zie het rode gedeelte!

Private Sub cmdrenewadressbook_Click()
Dim i As Integer
[COLOR="#FF0000"]On Error Resume Next[/COLOR]

Set OutApp = CreateObject("Outlook.Application")
Set myNameSpace = OutApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set mycontacts = myFolder.Items

For Each myContact In mycontacts
i = i + 1
 Worksheets("Addressbook").Range("A" & i) = myContact.FullName
 Worksheets("Addressbook").Range("B" & i) = myContact.Email1Address
 Worksheets("Addressbook").Range("C" & i) = myContact.Email2Address
 Worksheets("Addressbook").Range("D" & i) = myContact.Email3Address
Next

'Sorteeerd de adressen in sheet Adressbook
    Workbooks("Meldingen nieuw 2.0UC.xlsm").Worksheets("Adressbook").Sort.SortFields.Clear
    Workbooks("Meldingen nieuw 2.0UC.xlsm").Worksheets("Adressbook").Sort.SortFields.Add Key:=Range( _
        "A1:A10000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With Workbooks("Meldingen nieuw 2.0UC.xlsm").Worksheets("Adressbook").Sort
        .SetRange Range("A1:D10000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Past de kolommen A-D van worksheet aan breedte van de invoer aan
Workbooks("Meldingen nieuw 2.0UC.xlsm").Worksheets("Adressbook").Columns("A:D").AutoFit

Unload Me
frmmainmenu.Show

End Sub

Een oplossing, ik weet niet of het de goede is maar het werkt wel!!!

 

[pasan]

vanuit vakantie adres succes gewenst en mooi dat het werkt

 

[snb]

Voor een simpeler benadering zie http://www.snb-vba.eu/VBA_Outlook_external.html#L122