Récupérer adresses mails de la liste globale d'adresses OutlookRésolu

Question

Bonjour,

tout est dans le titre : j'ai un nom et un prénom, et je voudrais savoir si c'est possible de récupérer son adresse mail dans la liste d'adresses globale de mon Outlook depuis une base de données Access 2000, dans mon code VB. 
J'ai bien trouvé ceci : http://www.vbfrance.com/codes/CARNET-ADRESSE-OUTLOOK-VERS-EXCEL-OFFICE-2003-VS_45694.aspx mais ça ne fonctionne qu'avec le dossier Contacts, peut-être y a-t-il un moyen de l'adapter pour accéder à la liste d'adresses globale ?
J'ai également trouvé ce lien : http://access.developpez.com/faq/?page=Outlook#outlcarnet mais par cette méthode, on ne peut à priori pas récupérer l'adresse mail...

Quelqu'un a une idée ? 
Merci

kkhuet · Accepted Answer

je suis trop contente !!!! J'ai trouvé, voilà la solution pour ceux qui galèrent :

Public Sub AfficherAdresses()


     Dim objSession As MAPI.Session
     Dim objField As MAPI.Field
     Dim v


     Set objSession = CreateObject("MAPI.Session")
     objSession.Logon "st31844"


     ' Récupération de la propriété PR_EMS_AB_PROXY_ADDRESSES
     Set objField = objSession.AddressLists("Liste d'adresses globale").AddressEntries.Item("nom prénom").Fields(CdoPR_EMS_AB_PROXY_ADDRESSES)


     ' ATTENTION : PR_EMS_AB_PROXY_ADDRESSES est une propriété multivaluée
      ' (PT_MV_TSTRING).
     For Each v In objField.Value
         If InStr(v, "@") <> 0 Then
            MsgBox Right(v, Len(v) - 5)
        End If
     Next


    Set objField = Nothing
    objSession.Logoff
    Set objSession = Nothing


End Sub
Par contre, je ne sais pas encore comment cette fonction réagit quand la personne qu'on cherche a des homonymes..Je reviendrai sûrement sur ce poste si je trouve..

cs_Orohena · Answer

Bonjour

J'ai écrit la procédure ci-dessous en VBA Excel, mais je pense que tu n'auras aucune difficulté pour l'adapter pour Access.

Option Explicit
Sub liste_adresses_globales()
    Dim OutlookOlApp As Object
    Dim OutlookNameSpace As Namespace
    Dim nom As String, tabnom(1000) As String
    Dim ptr As Integer
    Dim adlst As AddressList
    Dim cnt1 As Integer
    Dim cnt2 As Integer
    Set OutlookOlApp = CreateObject("Outlook.Application")
    Set OutlookNameSpace = OutlookOlApp.GetNamespace("MAPI")
    cnt1 = 1
    Do Until LCase(OutlookNameSpace.AddressLists(cnt1)) = "liste d'adresses globale" _
        Or cnt1 = OutlookNameSpace.AddressLists.Count
        cnt1 = cnt1 + 1
    Loop
    Set adlst = OutlookNameSpace.AddressLists(cnt1)
    If Not LCase(OutlookNameSpace.AddressLists(cnt1)) = "liste d'adresses globale" Then
        MsgBox "L'application ne parvient pas à accéder à votre 'Liste d'adresses globales' outlook."
        Exit Sub
    End If
    cnt2 = adlst.AddressEntries.Count
    Application.ScreenUpdating = False          ' desactive la mise a jour de l'ecran
    For cnt1 = 1 To cnt2
        DoEvents
        Cells(cnt1, 1).Value = adlst.AddressEntries(cnt1)
    Next
    Application.ScreenUpdating = True           ' reactive la mise a jour de l'ecran
End Sub

Amicalement

cs_loulou69 · Answer

Oroena t'a répondu


Voici u code a tourné dans Access.

Email= ChercherAdresseEmail(nom & prenom)

Private Function ResoudreAdresse(ByVal str_adresse As String, Optional obj_adresse As Outlook.AddressEntry) As String


Dim app_outlook As Outlook.Application
Dim obj_message As Outlook.MailItem
Dim obj_destinataire As Outlook.Recipient


Set app_outlook = New Outlook.Application
Set obj_message = app_outlook.CreateItem(olMailItem)
Set obj_destinataire = obj_message.Recipients.Add(str_adresse)
If Not obj_destinataire.Resolve Then
    ResoudreAdresse = ""
    Set obj_adresse = Nothing
Else
    ResoudreAdresse = obj_destinataire.Name
    Set obj_adresse = obj_destinataire.AddressEntry
End If
obj_message.Delete
    
End Function


Function ChercherAdresseEmail(str_contact As String) As String


Dim obj_adresse As Outlook.AddressEntry


If Len(ResoudreAdresse(str_contact, obj_adresse)) > 0 Then
    ChercherAdresseEmail = obj_adresse.Address
Else
    ChercherAdresseEmail = ""
End If


End Function

kkhuet · Answer

Bonjour,

merci pour ces réponses, je viens de tester les 2 codes mais ça me donne exactement le même résultat que le 2ème lien que j'ai donné, à savoir une chaîne de caractères "/o=xxxxx/ou=FR/cn=Recipients/cn=yyyyyyy". Je ne vois pas d'adresse mail, peut-être en manipulant 'Recipients' ?..Il doit bien y avoir un moyen de récupérer toutes les infos d'un utilisateur (mail, société, ville etc...) !

cs_loulou69 · Answer

Essayer
ChercherAdresseEmail =obj_adresse.RecipAddress

kkhuet · Answer

test effectué --> message d'erreur "Propriété ou méthode non gérée par cet objet", ça doit être parce que j'utilise Access 2000..

cs_loulou69 · Answer

Desole
On ne peut pas avoir linformation aussi simplement
Ce doit etre un pb de protection
Je crois que la recuperation de ladresse email  nest possible que via les contacts

kkhuet · Answer

Bonjour,

encore une autre piste avec ceci :
http://209.85.229.132/search?q=cache:_kFPYau5aTwJ:download.microsoft.com/download/6/2/7/627bd63a-fc8c-4862-80f2-5e8f5174edaf/cdo.doc+AfficherAdresses()+Dim+objSession+As+MAPI.Session&hl=fr&ct=clnk&cd=2&gl=fr
par contre, ce bout de code ouvre une fenêtre d'Outlook dans laquelle on choisit une liste d'adresses et une personne, et je suis une grosse quiche parce que je n'arrive pas à mettre par défaut la lise d'adresses globale et un nom en particulier, dans le code..Quelqu'un comprend-il ce bout de code ? 
Je vais peut-être y arriver..

kkhuet · Answer

oups j'ai oublié de vous mettre ça dans le code :

Private Const CdoPR_EMS_AB_PROXY_ADDRESSES = &H800F101E

kkhuet · Answer

j'ai fait mon test avec un utilisateur qui a un homonyme dans la liste d'adresses globale, la ligne 
Set objField = objSession.AddressLists("Liste d'adresses globale").AddressEntries.Item("nom prénom").Fields(CdoPR_EMS_AB_PROXY_ADDRESSES)
me renvoie la première personne qui a ce nom/prénom, et c'est tout, quelqu'un sait s'il y a moyen de savoir quand il y en a plusieurs ? Même question pour savoir si la personne n'existe pas, car pour le moment lorsque la personne n'existe pas ça me renvoie la première personne qui a ce nom de famille, tant pis pour le prénom, et ce n'est évidemment pas ce que je veux !

kkhuet · Answer

ça y est j'ai tout trouvé, voilà la solution final pour ceux qui ont besoin.
D'abord je me sers des codes CDO que j'ai trouvé [www.cdolive.com/cdo10.htm ici].
Ensuite voici ma fonction, qui prend en paramètres le prénom et le nom de la personne à chercher dans Outlook :
Public Function ChercherContactOutlook(FirstName As String, _
                                        Name As String)
    'fonction qui cherche une personne dans Outlook à partir de son nom et son prénom
    'Si la personne n'existe pas ou s'il en existe plusieurs, la fonction renvoie "false"
    'Si la personne existe et qu'il n'y a pas d'ambiguité, la fonction renvoie la chaîne de caractères "pseudonyme;email;société"
    
    Dim objSession As MAPI.Session
    Dim objField As MAPI.Field
    Dim ol_adrEntries As MAPI.AddressEntries
    Dim ol_adrFilter As MAPI.AddressEntryFilter
    Const PR_EMAIL = &H39FE001E
    Const PR_PSEUDO = &H3A00001E
    Const PR_COMPANY_NAME = &H3A16001E
    
On Error GoTo ErrEnd



    Set objSession = CreateObject("MAPI.Session")
    objSession.Logon "TR40394"



    Set ol_adrEntries = objSession.AddressLists("Liste d'adresses globale").AddressEntries
    Set ol_adrFilter = ol_adrEntries.Filter
    ol_adrFilter.Name = Name & ", " & FirstName
    If ol_adrEntries.Count <> 1 Then
        'traitement plusieurs homonymes ou pas d'utilisateur correspondant à cette personne
        ChercherContactOutlook = "false"
    Else
        ChercherContactOutlook = ol_adrEntries.Item(1).Fields(PR_PSEUDO) & ";" & _
                                ol_adrEntries.Item(1).Fields(PR_EMAIL) & ";" & _
                                ol_adrEntries.Item(1).Fields(PR_COMPANY_NAME)
    End If



    Set objField = Nothing
    objSession.Logoff
    Set objSession = Nothing
    Set ol_adrEntries = Nothing
    Set ol_adrFilter = Nothing
    Exit Function
ErrEnd:
    MsgBox "Erreur N° " & Err.Number & vbLf & Err.Description, , Err.Source
End Function

kkhuet · Answer

pfffffff désolée pour le lien vers les constantes CDO, ça n'a pas fonctionné comme je le voulais, voici le bon : www.cdolive.com/cdo10.htm

Récupérer adresses mails de la liste globale d'adresses Outlook

12 réponses

Votre réponse

Discussions similaires