Récupérer une adresse mail dans Outlook en VBA

Bonjour à tous,

Mon niveau n'étant toujours pas mirobolant en VBA, je fais appel à votre aide.

Voici mon problème :

Je suis actuellement en stage dans une société ou les adresses mails sont soit au format prenom.nom@.... ou p.nom@.... .

Le fichier excel ci-joint à l'objectif suivant:

Lorsque l'on clique sur le bouton Envoyer les Mails:

Je voudrais que excel aille dans le carnet d'adresse chercher le nom de la personne en colonne E, me trouve son adresse mail et envoie un message du style: Nous avons pris en compte votre demande.

Pensez vous que cela est faisable ?

Pour précision l'adresse se trouve dans liste d'adresse globale de outlook .

J'ai glanner ce code sur le forum mais je le comprends qu'à moitié, il sera peut être utile.

Public Sub ExtractionOutlook()
    'Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library"
    'Extrait de la liste des contacts de Outlook le prénom et le nom des contacts
    Dim olApp As Outlook.Application
    Dim Cible As Outlook.ContactItem
    Dim DossierContacts As Outlook.MAPIFolder
    Dim ListeContact() As String
    Dim i, j As Integer

    Set olApp = New Outlook.Application
    Set DossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

    ReDim ListeContact(DossierContacts.Items.Count, 2)
    For Each Cible In DossierContacts.Items
        ListeContact(i, 0) = Cible.FirstName
        ListeContact(i, 1) = Cible.LastName
        ListeContact(i, 2) = Cible.Email1Address
        i = i + 1
    Next

    Sheets("Feuil1").Activate
    Range("A1").Select
    For j = 0 To i
        ActiveCell.Offset(j, 0) = ListeContact(j, 0)
        ActiveCell.Offset(j, 1) = ListeContact(j, 1)
        ActiveCell.Offset(j, 2) = ListeContact(j, 2)
    Next j

    Set Cible = Nothing
    Set DossierContacts = Nothing
    Set olApp = Nothing
End Sub

En vous remerciant de votre gentillesse par avance

CDT

Guillaume

Bonsoir,

Peut-être un début de réponse...

Option Explicit

Sub SendMail()
Dim OutApp, Contacts, OutMail As Object, i%
  Set OutApp = CreateObject("Outlook.Application")
  Set Contacts = OutApp.Session.Addresslists.Item(1).Addressentries
  For i = 1 To Contacts.Count
    If GetName(Contacts.Item(i).Name) = Me.Range("E5") Then
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
        .To = Contacts.Item(i).Address
        '.Subject =
         .Body = "Nous avons pris en compte votre demande."
        .Display '.Send pour envoyer directement
       End With
      Exit For
    End If
  Next i
  Set Contacts = Nothing: Set OutApp = Nothing: Set OutMail = Nothing
End Sub

Private Function GetName(ByVal aName As String)
  GetName = Left(aName, InStr(aName, "(") - 2)
End Function

Quelques remarques:

• Code à mettre dans la feuille.
• Je ne cherche ici que le contact référencé en E5 (il y a biensur possibilité de présenter la chose autrement).
• Le texte et la casse de la cellule E5 doivent correspondre au nom du contact de votre Outlook (pour la casse, ça se gère).
• Je scan ici tous les contacts donc s'il y en a énormément, ça peut être long...
• Si besoin, je commente...
• Sans votre Outlook, c'est un peu difficile de tester...

Cdt,

Darzou