utiliser le carnet d'adresses de outlook dans excel

Bonjour Misange,

Avec choix de la catégorie:

http://cjoint.com/?lziNvitERt

-Le formulaire peut être exporté avec Clic-droit/Exporter puis
importé dans un autre classeur avec Clic-Droit/Importer
-Ne pas oublier OUTILS/REFERENCE Microsoft /OutLook

Code du UserForm:

Dim Tbl()
Private Sub UserForm_Initialize()
Dim Temp()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
On Error Resume Next ' Contacts incomplets
For Each i In LItems
ReDim Preserve Tbl(0 To 3, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
Tbl(3, n) = i.Categories
n = n + 1
Next
On Error GoTo 0
Call triQ(Tbl, 0, n - 1)
Me.ListBox1.List = Application.Transpose(Tbl)
Set Mondico = CreateObject("Scripting.Dictionary")
Mondico.Add "(tous)", "(tous)"
For i = 0 To UBound(Tbl, 2)
Tmp = Split(Tbl(3, i), ";")
For k = LBound(Tmp) To UBound(Tmp)
If Not Mondico.Exists(Trim(Tmp(k))) Then Mondico.Add
Trim(Tmp(k)), Trim(Tmp(k))
Next k
Next i
Me.ChoixCatégorie.List = Mondico.Items
Me.ChoixCatégorie = "(tous)"
End Sub

Sub triQ(a(), gauc, droi)
' Quick sort
ref = a(0, (gauc + droi) 2)
g = gauc: d = droi
Do
Do While a(0, g) < ref: g = g + 1: Loop
Do While ref < a(0, d): d = d - 1: Loop
If g <= d Then
Temp = a(0, g): a(0, g) = a(0, d): a(0, d) = Temp
Temp = a(1, g): a(1, g) = a(1, d): a(1, d) = Temp
Temp = a(2, g): a(2, g) = a(2, d): a(2, d) = Temp
Temp = a(3, g): a(3, g) = a(3, d): a(3, d) = Temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call triQ(a, g, droi)
If gauc < d Then Call triQ(a, gauc, d)
End Sub

Private Sub ListBox1_Click()
On Error Resume Next
[A1] = ListBox1
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
[A4] = ListBox1.Column(3)
End Sub

Private Sub ChoixCatégorie_Change()
Dim Temp()
If Me.ChoixCatégorie = "(tous)" Then
Me.ListBox1.List = Application.Transpose(Tbl)
Else
j = 0
For i = 0 To UBound(Tbl, 2)
If InStr(Tbl(3, i), Me.ChoixCatégorie) > 0 Then
ReDim Preserve Temp(0 To 3, 0 To j)
Temp(0, j) = Tbl(0, i)
Temp(1, j) = Tbl(1, i)
Temp(2, j) = Tbl(2, i)
Temp(3, j) = Tbl(3, i)
j = j + 1
End If
Next i
If UBound(Temp, 2) > 0 Then
Me.ListBox1.List = Application.Transpose(Temp)
Else
ReDim Preserve Temp(0 To 3, 0 To j)
Temp(0, j) = ""
Temp(1, j) = ""
Temp(2, j) = ""
Temp(3, j) = ""
Me.ListBox1.List = Application.Transpose(Temp)
End If
End If
End Sub

JB

Super !
Est ce que tu crois qu'on peut raffiner un peu encore : les contacts qui
sont à afficher ne sont qu'un sous groupe des contacts uotlook. Ils sont
caractérisés par le fait qu'ils appartiennent tous à la catégorie
"professionnel" par exemple.
Encore une chose : ou trouves tu la liste de tous les items présents
dans les contacts (en fait leur nom VBA) ?
vraiment pratique ce truc ! je sens que ça fera encore un classeur en
téléchargement sur excelabo :-)

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

version modifiée pour contacts incomplets et tri + rapide:

http://cjoint.com/?lyeMX8YFlZ
http://cjoint.com/?lyeN2u1QN5

Private Sub UserForm_Initialize()
Dim Tbl()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
On Error Resume Next ' Contacts incomplets
For Each i In LItems
ReDim Preserve Tbl(0 To 2, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
n = n + 1
Next
On Error GoTo 0
Call triQ(Tbl, 0, n - 1)
Me.ListBox1.List = Application.Transpose(Tbl)
End Sub

Sub triQ(a(), gauc, droi)
' Quick sort
ref = a(0, (gauc + droi) 2)
g = gauc: d = droi
Do
Do While a(0, g) < ref: g = g + 1: Loop
Do While ref < a(0, d): d = d - 1: Loop
If g <= d Then
temp = a(0, g): a(0, g) = a(0, d): a(0, d) = temp
temp = a(1, g): a(1, g) = a(1, d): a(1, d) = temp
temp = a(2, g): a(2, g) = a(2, d): a(2, d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call triQ(a, g, droi)
If gauc < d Then Call triQ(a, gauc, d)
End Sub

Private Sub ListBox1_Click()
[A1] = ListBox1 ' Récupération contact
choisi
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
End Sub

JB

bon en fait un petit on error resume next judicieusement placé rés oud le
problème de contacts incomplets auxquels il manque soit le nom soit le
prénom ce qui plantait la macro.
Merci pour le joli boulot à tous
(ps le meme on error resule next résoud le même pb dans la macro de
Denis ;-))

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour JB
Merci de te pencher aussi sur le problème !
J'obtiens un "propriété ou méthode non gérée par cet objet" à
l'affichage du userform. En suivant pas à pas, il semble que les
éléments des contacts ne soient pas intégrés dans le tableau, car
"indice n'appartient pas à la sélection".
JE suis avec outlook 2002 et en cochant la bonne librairie ca colle ( ça
c'est pour répondre à Jean luc)

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour Misange,

Liste triée des contacts dans un formulaire:
Pour récupérer le formulaire dans un classeur Excel, utiiliser
Exporter/Importer formulaire.

http://cjoint.com/?lxfPfkbKKn

Private Sub UserForm_Initialize()
' Outils/Référence OutLook
Dim Tbl()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
For Each i In LItems
ReDim Preserve Tbl(0 To 2, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
n = n + 1
Next
Tri Tbl()
Me.ListBox1.List = Application.Transpose(Tbl)
End Sub

Sub Tri(table())
xn = UBound(table, 2)
ecart = xn ' tri shell
Do While ecart >= 1
ecart = ecart 2
inv = True
Do While inv
inv = False
For i = 0 To xn - ecart
j = i + ecart
If table(0, j) < table(0, i) Then
temp = table(0, j): table(0, j) = table(0, i): table(0, i) =
temp
temp = table(1, j): table(1, j) = table(1, i): table(1, i) =
temp
temp = table(2, j): table(2, j) = table(2, i): table(2, i) =
temp
inv = True
End If
Next
Loop
Loop
End Sub

Private Sub ListBox1_Click()
[A1] = ListBox1
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
End Sub

JB

Coucou
Tout est dans le titre... Comment récupérer dans excel les adre sses qui
sont dans outlook ? J'ai cherché sur excelabo mais c'est un pur s candale
ça y est même pas !!!
idéalement ce serait bien d'y accéder via un menu déroulant.
Il ne s'agit PAS de faire du publipostage mais juste d'incorporer u ne
adresse dans une feuille excel.
Merci de votre aide ;-)
--
Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour JB

Alors là vraiment c'est exactement ce dont j'avais besoin. Vraiment
merci c'est super pratique.
:-) :-)

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour Misange,

Avec choix de la catégorie:

http://cjoint.com/?lziNvitERt

-Le formulaire peut être exporté avec Clic-droit/Exporter puis
importé dans un autre classeur avec Clic-Droit/Importer
-Ne pas oublier OUTILS/REFERENCE Microsoft /OutLook

Code du UserForm:

Dim Tbl()
Private Sub UserForm_Initialize()
Dim Temp()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
On Error Resume Next ' Contacts incomplets
For Each i In LItems
ReDim Preserve Tbl(0 To 3, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
Tbl(3, n) = i.Categories
n = n + 1
Next
On Error GoTo 0
Call triQ(Tbl, 0, n - 1)
Me.ListBox1.List = Application.Transpose(Tbl)
Set Mondico = CreateObject("Scripting.Dictionary")
Mondico.Add "(tous)", "(tous)"
For i = 0 To UBound(Tbl, 2)
Tmp = Split(Tbl(3, i), ";")
For k = LBound(Tmp) To UBound(Tmp)
If Not Mondico.Exists(Trim(Tmp(k))) Then Mondico.Add
Trim(Tmp(k)), Trim(Tmp(k))
Next k
Next i
Me.ChoixCatégorie.List = Mondico.Items
Me.ChoixCatégorie = "(tous)"
End Sub

Sub triQ(a(), gauc, droi)
' Quick sort
ref = a(0, (gauc + droi) 2)
g = gauc: d = droi
Do
Do While a(0, g) < ref: g = g + 1: Loop
Do While ref < a(0, d): d = d - 1: Loop
If g <= d Then
Temp = a(0, g): a(0, g) = a(0, d): a(0, d) = Temp
Temp = a(1, g): a(1, g) = a(1, d): a(1, d) = Temp
Temp = a(2, g): a(2, g) = a(2, d): a(2, d) = Temp
Temp = a(3, g): a(3, g) = a(3, d): a(3, d) = Temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call triQ(a, g, droi)
If gauc < d Then Call triQ(a, gauc, d)
End Sub

Private Sub ListBox1_Click()
On Error Resume Next
[A1] = ListBox1
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
[A4] = ListBox1.Column(3)
End Sub

Private Sub ChoixCatégorie_Change()
Dim Temp()
If Me.ChoixCatégorie = "(tous)" Then
Me.ListBox1.List = Application.Transpose(Tbl)
Else
j = 0
For i = 0 To UBound(Tbl, 2)
If InStr(Tbl(3, i), Me.ChoixCatégorie) > 0 Then
ReDim Preserve Temp(0 To 3, 0 To j)
Temp(0, j) = Tbl(0, i)
Temp(1, j) = Tbl(1, i)
Temp(2, j) = Tbl(2, i)
Temp(3, j) = Tbl(3, i)
j = j + 1
End If
Next i
If UBound(Temp, 2) > 0 Then
Me.ListBox1.List = Application.Transpose(Temp)
Else
ReDim Preserve Temp(0 To 3, 0 To j)
Temp(0, j) = ""
Temp(1, j) = ""
Temp(2, j) = ""
Temp(3, j) = ""
Me.ListBox1.List = Application.Transpose(Temp)
End If
End If
End Sub

JB

Super !
Est ce que tu crois qu'on peut raffiner un peu encore : les contacts qui
sont à afficher ne sont qu'un sous groupe des contacts uotlook. Ils sont
caractérisés par le fait qu'ils appartiennent tous à la catégorie
"professionnel" par exemple.
Encore une chose : ou trouves tu la liste de tous les items présents
dans les contacts (en fait leur nom VBA) ?
vraiment pratique ce truc ! je sens que ça fera encore un classeur en
téléchargement sur excelabo :-)

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

version modifiée pour contacts incomplets et tri + rapide:

http://cjoint.com/?lyeMX8YFlZ
http://cjoint.com/?lyeN2u1QN5

Private Sub UserForm_Initialize()
Dim Tbl()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
On Error Resume Next ' Contacts incomplets
For Each i In LItems
ReDim Preserve Tbl(0 To 2, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
n = n + 1
Next
On Error GoTo 0
Call triQ(Tbl, 0, n - 1)
Me.ListBox1.List = Application.Transpose(Tbl)
End Sub

Sub triQ(a(), gauc, droi)
' Quick sort
ref = a(0, (gauc + droi) 2)
g = gauc: d = droi
Do
Do While a(0, g) < ref: g = g + 1: Loop
Do While ref < a(0, d): d = d - 1: Loop
If g <= d Then
temp = a(0, g): a(0, g) = a(0, d): a(0, d) = temp
temp = a(1, g): a(1, g) = a(1, d): a(1, d) = temp
temp = a(2, g): a(2, g) = a(2, d): a(2, d) = temp
g = g + 1: d = d - 1
End If
Loop While g <= d
If g < droi Then Call triQ(a, g, droi)
If gauc < d Then Call triQ(a, gauc, d)
End Sub

Private Sub ListBox1_Click()
[A1] = ListBox1 ' Récupération contact
choisi
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
End Sub

JB

bon en fait un petit on error resume next judicieusement placé résoud le
problème de contacts incomplets auxquels il manque soit le nom soit le
prénom ce qui plantait la macro.
Merci pour le joli boulot à tous
(ps le meme on error resule next résoud le même pb dans la macro de
Denis ;-))

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour JB
Merci de te pencher aussi sur le problème !
J'obtiens un "propriété ou méthode non gérée par cet objet" à
l'affichage du userform. En suivant pas à pas, il semble que les
éléments des contacts ne soient pas intégrés dans le tableau, car
"indice n'appartient pas à la sélection".
JE suis avec outlook 2002 et en cochant la bonne librairie ca colle (ça
c'est pour répondre à Jean luc)

Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net

Bonjour Misange,

Liste triée des contacts dans un formulaire:
Pour récupérer le formulaire dans un classeur Excel, utiiliser
Exporter/Importer formulaire.

http://cjoint.com/?lxfPfkbKKn

Private Sub UserForm_Initialize()
' Outils/Référence OutLook
Dim Tbl()
Dim olNS As Outlook.Namespace
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set Contacts = olNS.GetDefaultFolder(olFolderContacts)
Set LItems = Contacts.Items
n = 0
For Each i In LItems
ReDim Preserve Tbl(0 To 2, 0 To n)
Tbl(0, n) = i.FirstName
Tbl(1, n) = i.LastName
Tbl(2, n) = i.Email1Address
n = n + 1
Next
Tri Tbl()
Me.ListBox1.List = Application.Transpose(Tbl)
End Sub

Sub Tri(table())
xn = UBound(table, 2)
ecart = xn ' tri shell
Do While ecart >= 1
ecart = ecart 2
inv = True
Do While inv
inv = False
For i = 0 To xn - ecart
j = i + ecart
If table(0, j) < table(0, i) Then
temp = table(0, j): table(0, j) = table(0, i): table(0, i) >>>>>> temp
temp = table(1, j): table(1, j) = table(1, i): table(1, i) >>>>>> temp
temp = table(2, j): table(2, j) = table(2, i): table(2, i) >>>>>> temp
inv = True
End If
Next
Loop
Loop
End Sub

Private Sub ListBox1_Click()
[A1] = ListBox1
[A2] = ListBox1.Column(1)
[A3] = ListBox1.Column(2)
End Sub

JB

Coucou
Tout est dans le titre... Comment récupérer dans excel les adresses qui
sont dans outlook ? J'ai cherché sur excelabo mais c'est un pur scandale
ça y est même pas !!!
idéalement ce serait bien d'y accéder via un menu déroulant.
Il ne s'agit PAS de faire du publipostage mais juste d'incorporer une
adresse dans une feuille excel.
Merci de votre aide ;-)
--
Misange migrateuse
XlWiki : Participez à un travail collaboratif sur excel !
http://xlwiki.free.fr/wiki
http://www.excelabo.net