VBA Excel rajouter CompanyName (de GAL outlook-Exchange)

Bonjour,

À tout hasard (je ne connais pas vraiment le modèle objet d'outlook)

D'après cette adresse :
https://msdn.microsoft.com/fr-fr/vba/outlook-vba/articles/addressentries-object-outlook

La boucle pourrait ressembler à ceci :

Worksheets("ListeAdr").Range("a:a").ClearContents
With GaddressList
.GetFirst
For a = 1 To .Count
[A1048575].End(xlUp)(2) = .Item.Name
.GetNext
.Next
End With


MichD






"LSteph" a écrit dans le message de groupe de discussion :
7241ed62-7ef4-4ae9-a256-428d9b7d7c0c@googlegroups.com...


Bonjour,

Contexte:
Office Excel Programmation Microsoft Office Office 2010
VBA

Je cherche, en plus des noms de la liste d'adresse Globale,
à mettre à coté le nom de Société:
soit le CompanyName mais je patauge un peu
voir dans le code qui va pour les noms ..en commentaire:

merci d'avance

'---
Sub ListeAdresses()
Dim OlApp As Object
Dim NS As Object, GaddressList
Dim myr As Range


Set OlApp = CreateObject("Outlook.Application")
Set NS = OlApp.GetNameSpace("MAPI")
Set GaddressList = NS.Session.AddressLists("Liste d'adresses Globale")
Worksheets("ListeAdr").Range("a:b").ClearContents
For Each Item In GaddressList.AddressEntries


Set myr = [A1048575].End(xlUp)(2)
myr.Cells(1) = Item.Name
'Ici je voudrais mettre: myr.offset(0,1)=xxx?xxx.CompanyName
Next

End Sub

'LSteph

Et ceci :

La bibliothèque Microsoft Outlook doit être coché dans menu / références.

'----------------------------------------------
Sub ImporterContacts()
Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim ObjFolder As MAPIFolder
Dim NumLigne As Integer
Dim NbContacts As Integer

Set objApp = New Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set ObjFolder = objNS.GetDefaultFolder(olFolderContacts)

NumLigne = 1
NbContacts = ObjFolder.Items.Count

For A = 1 To NbContacts
NumLigne = NumLigne + 1
With Worksheets("Feuil1")
.Cells(NumLigne, 1) = ObjFolder.Items(A)
.Cells(NumLigne, 2) = ObjFolder.Items(A).FirstName
.Cells(NumLigne, 3) = ObjFolder.Items(A).LastName
.Cells(NumLigne, 4) = ObjFolder.Items(A).Email1Address
.Cells(NumLigne, 5) = ObjFolder.Items(A).CompanyName
End With
Next
Set objApp = Nothing: Set objNS = Nothing: Set ObjFolder = Nothing
End Sub
'----------------------------------------------

MichD

Bonjour,

Il va (moyennant de filtrer l'erreur en cas de rubrique vide) pour les Cont atcs
mais pas pour la liste d'adresse globale qui ne semble pas ressortir d'un M APIfolder. J'ai essayé d'adapter ca veut pas
j'ai aussi tenté de typer en tant qu'objcet mais bien sûr ca ne va pas.:
ub ImporterLG()
Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim ObjFolder As Object
Dim NumLigne As Integer
Dim NbContacts As Integer

Set objApp = New Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set ObjFolder = NS.Session.AddressLists("Liste d'adresses Globale")'bug

NumLigne = 1
NbContacts = ObjFolder.Items.Count

For A = 1 To NbContacts
NumLigne = NumLigne + 1
On Error Resume Next
With Worksheets("Feuil2")
.Cells(NumLigne, 1) = ObjFolder.Items(A)
.Cells(NumLigne, 2) = ObjFolder.Items(A).FirstName
.Cells(NumLigne, 3) = ObjFolder.Items(A).LastName
.Cells(NumLigne, 4) = ObjFolder.Items(A).Email1Address
.Cells(NumLigne, 5) = ObjFolder.Items(A).CompanyName
End With
On Error GoTo 0
Next
Set objApp = Nothing: Set objNS = Nothing: Set ObjFolder = Nothing
End Sub

... c'est parti tronqué
je continue à chercher.


En tout cas merci

--
LSteph

Re,
La piste donnée par Daniel me mène à cette adaptation
vu le nombre d'entrées de nos listes c'est un peu long mais ça le fait.
Merci

Sub ImporLG()

Dim colAL As Outlook.AddressLists

Dim oAL As Outlook.AddressList

Dim colAE As Outlook.AddressEntries

Dim oAE As Outlook.AddressEntry

Dim oExUser As Outlook.ExchangeUser

Dim OlApp As New Outlook.Application

Dim i As Long

Set colAL = OlApp.Session.AddressLists

Application.ScreenUpdating = False

'Vider la feuille
Feuil2.[A2:B100000].ClearContents
'Commencer après le titre
i = 2
'Boucle dans les Adress Lists
For Each oAL In colAL

' si l'Address list est une liste globale Exchange

If oAL.AddressListType = olExchangeGlobalAddressList Then
'colAE représente l'ensemble des contacts
Set colAE = oAL.AddressEntries
'Boucle sur les contacts
For Each oAE In colAE
'Si le contact est un contact de type Exchange User
If oAE.AddressEntryUserType = olExchangeUserAddre ssEntry Then
'récupère l 'objet Exchange User du conta ct
i = i + 1
Set oExUser = oAE.GetExchangeUser
'on a accès aux diverses propriété de l' objet dont CompanyName
Feuil2.Cells(i, 1) = oExUser.Name
Feuil2.Cells(i, 2) = oExUser.CompanyName
End If

Next

End If

Next
Application.ScreenUpdating = True
End Sub

Une dernière tentative, je n'ai pas un environnement pour effectuer des
tests!

Tu utilises une partie de ton code pour trouver le nom et tu insères les
lignes
de code complémentaires de la procédure suivante. Attention aux noms des
variables.

'------------------------------------------------------------------------
Sub test()

Dim SonNom As String
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olRecip As Outlook.Recipient
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries
Dim olAddrEntry As Outlook.AddressEntry
Dim exUser As Outlook.ExchangeUser
Dim olCont As Outlook.ContactItem

Set olA = New Outlook.Application
Set olNS = olA.GetNamespace("MAPI")

'Pour chacun des noms de ta procédure
'tu récupères le nom que tu places dans
'la variable SonNom et tu insères à la suite
'ce bout de code.

Set olRecip = olNS.CreateRecipient(SonNom)
olRecip.Resolve
Set olAddrEntry = olRecip.AddressEntry
Set olCont = olAddrEntry.GetContact
If Not (olCont Is Nothing) Then
'this is a contact
'olCont is ContactItem object
MsgBox olCont.FullName
Else
Set olExchUser = olAddrEntry.GetExchangeUser
If Not (olExchUser Is Nothing) Then
'olExchUser is ExchangeUser object
MsgBox olExchUser.CompanyName
End If
End If
End Sub
'------------------------------------------------------------------------

MichD