VBA Excel rajouter CompanyName (de GAL outlook-Exchange)

Le
LSteph
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
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
News.aioe.org
Le #26437414
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 :

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
News.aioe.org
Le #26437426
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
LSteph
Le #26437427
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
LSteph
Le #26437430
... c'est parti tronqué
je continue à chercher.
En tout cas merci
--
LSteph
LSteph
Le #26437437
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
News.aioe.org
Le #26437443
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
Publicité
Poster une réponse
Anonyme