Discussion :

[mdb008]

Bonjour,

J'ai créé une macro qui me permet d'envoyer un mail automatique aux adresses mail figurant dans mon tableau excel lorsque certaines conditions sont respectées.

Actuellement, pour que le mail soit envoyé, il faut donc que je rentre manuellement les adresses mail correspondant à chaque personne présente dans le tableau. Sachant que je rentre aussi le nom + prénom des personnes, est-ce qu'il ne serait pas possible de récupérer automatiquement l'adresse mail dans le carnet d'adresse outlook de mon entreprise (contacts partagés, pas contacts perso) ?

Voici le code que je souhaite modifier. Vous trouverez également le fichier en PJ pour mieux comprendre.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
     'Définition des variables
    Public Sub EnvoiMailRappel()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim adresse As String
    Dim message As String
    Dim sujet As String
 
    sujet = "Retour Prêt" 'Définition du sujet de l'email
    For i = 3 To Range("a" & Rows.Count).End(xlUp).Row 'Définition de la plage de test (de la 3ème ligne jusqu'à première cellule vide de la colonne a
    If Range("o" & i) = "" Then 'Si aucun mail n'a été envoyé alors on lance la recherche sur la date
 
    If Range("h" & i) <> "" And Range("i" & i) <> "" And Now() > Range("i" & i) Then ' Si la cellule de date prêt n'est pas vide et que la date de retour est arrivée à expiration alors envoyer le mail
 
    adresse = Range("g" & i) 'Recherche l'adresse mail du destinataire
    ' Définition du message
    message = "Bonjour " & Range("e" & i) & "," & vbCrLf & vbCrLf & "Un " & Range("a" & i) & " " & _
    Range("b" & i) & " " & "ayant pour IMEI " & Range("c" & i) & " " & "t'a été prêté le " & _
    Range("h" & i) & ". " & "La période de prêt étant arrivée à échéance, merci de bien vouloir nous le rapporter, ou à défaut, me contacter." & _
    vbCrLf & vbCrLf & "Bien cordialement," & vbCrLf
 
    'Paramètres de l'application mail
    Set OutlookApp = CreateObject("outlook.application")
    Set OutlookMail = OutlookApp.createitem(0)
    With OutlookMail
    .Subject = sujet
    .To = adresse
    .body = message
    .send 'envoi du mail
 
    Range("o" & i).Value = Now 'lorsqu'un mail a été enovyé, la cellule en i est remplie avec la date d'envoi du mail afin d'éviter l'envoi de plusieurs mails
 
    End With
 
    End If
    End If
    Next i
 
 
    End Sub

Merci d'avance pour votre aide.
Bien cordialement,
mdb008

[parmi]

Bonjour,

Utilisez-vous un serveur Exchange ?

Ce lien pourrait sûrement t'être utile

[mdb008]

Bonjour Parmi,

Merci de ta réponse. En effet, nous utilisons un serveur Exchange.

Par contre je ne suis vraiment débutant en VBA donc je ne vois pas comment adapter mon code avec cette nouvelle fonctionnalité. J'ai besoin d'un peu d'aide là dessus, si ce n'est pas trop demandé...

Encore merci !

[parmi]

Tu pourrais essayer ce code en le modifiant au besoin.
Selon le nombre de contacts que tu recherches et le nombre de contacts qu'il y a dans votre base de données, ça peut être long, toutefois...

Inscris le prénom recherché en A2, le nom en B2 et l'adresse courriel devrait s'afficher en C2
Plusieurs autres possibilités existent (téléphone, adresse civique,...)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub Rechercher()
    Dim OLApp As New Outlook.Application
    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 Nom As String, Prenom As String
 
    Prenom = Range("A2")
    Nom = Range("B2")
 
    Set colAL = OLApp.Session.AddressLists
 
    For Each oAL In colAL
 
        If oAL.AddressListType = olExchangeGlobalAddressList Then
            Set colAE = oAL.AddressEntries
            For Each oAE In colAE
 
                If oAE.AddressEntryUserType = olExchangeUserAddressEntry _
                    Or oAE.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
 
                Set oExUser = oAE.GetExchangeUser
 
                If oExUser.LastName = Nom And oExUser.FirstName = Prenom Then
                    Range("C2") = oExUser.PrimarySmtpAddress
                    Exit For
                End If
 
                End If
            Next
        End If
    Next
 
End Sub

[mdb008]

Merci beaucoup Parmi, c'est parfait !

Par contre je pense que notre base de contacts est trop importante car lorsque je lance la macro, le chargement ne s'arrête pas, même après 30min...

Du coup je crois qu'il n'est pas envisageable d'intégrer cette fonctionnalité dans notre entité... Tant pis.

Encore merci pour tout, j'espère que ton travail servira à d'autres

[parmi]

Je trouve que 30 minutes c'est beaucoup.
Combien de personnes recherches-tu et dans une liste de quelle ordre de grandeur ?

Ici, la liste contient quelques dizaines de milliers de noms.
Les noms commençant par A sont trouvés plus rapidement que les Z, mais c'est question de secondes...