Envoie de mail à partir d'un nom et d'un prénom

Le 25/07/2018 à 11:33

Bonjour,

dans le cadre d'une mission j'ai pour objectifs de créer un mail depuis une liste excel afin de signifier à l'utilisateur et à son responsable que ce dernier (l'utilisateur)

doit restituer son pc.

Mon problème est le suivant: les utilisateurs et reponsables sont inscrits via leurs noms, prénoms dans le fichier Excel,

ma macro doit convertir ces données pour en faire resortir une adresse mail valide.

quelqu'un a t-il une idée?

Merci d'avance

Mon code:

Sub TesteDate()

        'envoie un mail si la date est dépassée
    Dim sSujet, sBody, sNom As String, sAdresseMail As String, sAdresseResp As String, sAdresseRetour As String  'chaines pour le sujet, corps, adresse d'envoi, adresse de retour
    Dim duree As Integer 'nbre de jours entre aujourd'hui et la date à tester
    Dim Lig_Deb, Lig_Fin As Integer 'ligne de début, de fin
    Dim sDates_Col, sMails_Col As String 'colonnes qui contiennent les dates à tester et les adresses mail
    Dim i As Integer

    'initialisation des constantes de la macro :
    Lig_Deb = 2 'dans ma feuille Excel, les dates à tester commencent en ligne 2
    sDates_Col = "G" ' et elles sont en colonne B et les adresses mail sont en colonne D à côté

    'initialisation des données du mail envoyé :
    sSujet = "Restitution PC DELL  :"
    sBody = "Bonjour" + vbNewLine + "PC à rendre" + vbNewLine + "Cordialement" + vbNewLine + "NTT DATA" + vbNewLine
    sAdresseRetour = "alexandre_martonsky_98@hotmail.fr"

    'Ligne de fin =1ère cellule vide dans la colonne des dates
    Lig_Fin = Cells(1, 1).CurrentRegion.Rows.Count

    ' boucle de test dans la plage des dates (=> )
    For i = Lig_Deb To Lig_Fin
        duree = Int(Now) - Cells(i, 4).Value ' la date est dans la cellule active
        If duree > 3 Then 'la date est dépassée
            sNom = Cells(i, 6)
            sAdresseMail = Cells(i, 9)
            If Trim(sAdresseMail) = "" Then

                If Resolution_adresseEmail(sNom, sAdresseMail, sAdresseResp) Then
                    Cells(i, 9) = sAdresseMail
                    Cells(i, 10) = sAdresseResp
                End If

            End If

            If sAdresseMail <> "" Then
                sAdresseResp = Cells(i, 10) 'l'adresse mail est dans la colonne suivante offset (0,1)
                MsgBox ("Envoi de courrier à " & sAdresseMail)
                ' envoyer le mail :
                CDO_SendMail sSujet, sBody, sAdresseMail, sAdresseResp, sAdresseRetour
            End If
        Else
         'MsgBox ("La date n'est pas atteinte")
        End If

    Next i

End Sub

Function Resolution_adresseEmail(ByVal sNom As String, ByRef Email_User As String, ByRef Email_Resp As String)

    Dim olA As Object
    Dim olNS As Object
    Dim olRecip As Object

    Resolution_adresseEmail = False

    On Error GoTo Erreur

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

    olRecip.Resolve
    Set olAddrEntry = olRecip.AddressEntry
    Set olCont = olAddrEntry.GetContact
    If olCont Is Nothing Then

      Set olExchUser = olAddrEntry.GetExchangeUser
      If Not (olExchUser Is Nothing) Then
        'olExchUser is ExchangeUser object
        Email_User = olExchUser.PrimarySmtpAddress
        Email_Resp = olExchUser.Manager.PrimarySmtpAddress
        Resolution_adresseEmail = True
      End If
    End If

Erreur:

    Set olRecip = Nothing
    Set olNS = Nothing
    Set olA = Nothing

End Function

Sub Test()
Dim Var1 As String
Dim Var2 As String

     Var3 = Resolution_adresseEmail("xxxxx yyy", Var1, Var2)
     Debug.Print Var1, Var2, Var3

End Sub

Sub CDO_SendMail(ByVal sSujet As String, ByVal sBody As String, ByVal sAdresseMail As String, ByVal sAdresseResp As String, ByVal sAdresseRetour)

    'MARCHE IMPEC, sans demande de confirmation ;-)))))
    'on peut préciser : le sujet, le corps , l'adresse mail, l'adresse de retour
    Dim iMsg As Object
    Dim iConf As Object
    Dim flds As Object
    Dim schema As String

    Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
    Const cdoAnonymous = 0

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set flds = iConf.Fields

    With iMsg
        .To = sAdresseMail
        .Sender = sAdresseRetour 'adresse de l'expéditeur pour le rapport envoyé
        .From = sAdresseRetour 'adresse de l'expéditeur du mail
        .ReplyTo = sAdresseRetour 'adresse à laquelle sera envoyée la réponse
        .CC = sAdresseResp
        .BCC = ""
        .Subject = sSujet 'sujet du message
        .TextBody = sBody 'corps du message
        .AddAttachment Fichier 'fichier joint
        .DSNOptions = 14 'confirmation demandée dans tous les cas (voir ci-dessous avec 14 8 + 4 + 2)
        ' (0=pas réponse ; 2=rapport si échec ; 4=rapport si réussi ; 8=rapport si délai)

        ' pour demander des confirmations de réception ou d'envoi :
        .Fields("urn:schemas:mailheader:return-receipt-to") = sAdresseRetour
        .Fields("urn:schemas:mailheader:disposition-notification-to") = sAdresseRetour

        ' Configuration du serveur SMTP
        schema = "http://schemas.microsoft.com/cdo/configuration/"
        flds.Item(schema & "sendusing") = cdoSendUsingPort
        flds.Item(schema & "smtpserver") = "mail.aviva.com"
        flds.Item(schema & "smtpserverport") = 25
        flds.Item(schema & "smtpauthenticate") = cdoAnonymous
        flds.Item(schema & "smtpusessl") = False
        flds.Update

        ' Update fields
        .Fields.Update

        ' envoi
        Set .Configuration = iConf
        .Send

    End With

End Sub
Le 25/07/2018 à 11:40

Bonjour,

Ne cherchez pas de différences avec le code posté précédemment, il n'y en a pas... C'est juste pour faciliter la lecture... Non, ne me remerciez pas ! 

Sub TesteDate()

'envoie un mail si la date est dépassée
Dim sSujet, sBody, sNom As String, sAdresseMail As String, sAdresseResp As String, sAdresseRetour As String 'chaines pour le sujet, corps, adresse d'envoi, adresse de retour
Dim duree As Integer 'nbre de jours entre aujourd'hui et la date à tester
Dim Lig_Deb, Lig_Fin As Integer 'ligne de début, de fin
Dim sDates_Col, sMails_Col As String 'colonnes qui contiennent les dates à tester et les adresses mail
Dim i As Integer

'initialisation des constantes de la macro :
Lig_Deb = 2 'dans ma feuille Excel, les dates à tester commencent en ligne 2
sDates_Col = "G" ' et elles sont en colonne B et les adresses mail sont en colonne D à côté

'initialisation des données du mail envoyé :
sSujet = "Restitution PC DELL :"
sBody = "Bonjour" + vbNewLine + "PC à rendre" + vbNewLine + "Cordialement" + vbNewLine + "NTT DATA" + vbNewLine
sAdresseRetour = "alexandre_martonsky_98@hotmail.fr"

'Ligne de fin =1ère cellule vide dans la colonne des dates
Lig_Fin = Cells(1, 1).CurrentRegion.Rows.Count

' boucle de test dans la plage des dates (=> )
For i = Lig_Deb To Lig_Fin
duree = Int(Now) - Cells(i, 4).Value ' la date est dans la cellule active
If duree > 3 Then 'la date est dépassée
sNom = Cells(i, 6)
sAdresseMail = Cells(i, 9)
If Trim(sAdresseMail) = "" Then

If Resolution_adresseEmail(sNom, sAdresseMail, sAdresseResp) Then
Cells(i, 9) = sAdresseMail
Cells(i, 10) = sAdresseResp
End If

End If

If sAdresseMail <> "" Then
sAdresseResp = Cells(i, 10) 'l'adresse mail est dans la colonne suivante offset (0,1)
MsgBox ("Envoi de courrier à " & sAdresseMail)
' envoyer le mail :
CDO_SendMail sSujet, sBody, sAdresseMail, sAdresseResp, sAdresseRetour
End If
Else
'MsgBox ("La date n'est pas atteinte")
End If

Next i

End Sub

Function Resolution_adresseEmail(ByVal sNom As String, ByRef Email_User As String, ByRef Email_Resp As String)

Dim olA As Object
Dim olNS As Object
Dim olRecip As Object

Resolution_adresseEmail = False

On Error GoTo Erreur

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

olRecip.Resolve
Set olAddrEntry = olRecip.AddressEntry
Set olCont = olAddrEntry.GetContact
If olCont Is Nothing Then

Set olExchUser = olAddrEntry.GetExchangeUser
If Not (olExchUser Is Nothing) Then
'olExchUser is ExchangeUser object
Email_User = olExchUser.PrimarySmtpAddress
Email_Resp = olExchUser.Manager.PrimarySmtpAddress
Resolution_adresseEmail = True
End If
End If

Erreur:

Set olRecip = Nothing
Set olNS = Nothing
Set olA = Nothing

End Function

Sub Test()
Dim Var1 As String
Dim Var2 As String

Var3 = Resolution_adresseEmail("xxxxx yyy", Var1, Var2)
Debug.Print Var1, Var2, Var3

End Sub

Sub CDO_SendMail(ByVal sSujet As String, ByVal sBody As String, ByVal sAdresseMail As String, ByVal sAdresseResp As String, ByVal sAdresseRetour)

'MARCHE IMPEC, sans demande de confirmation ;-)))))
'on peut préciser : le sujet, le corps , l'adresse mail, l'adresse de retour
Dim iMsg As Object
Dim iConf As Object
Dim flds As Object
Dim schema As String

Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
Const cdoAnonymous = 0

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set flds = iConf.Fields

With iMsg
.To = sAdresseMail
.Sender = sAdresseRetour 'adresse de l'expéditeur pour le rapport envoyé
.From = sAdresseRetour 'adresse de l'expéditeur du mail
.ReplyTo = sAdresseRetour 'adresse à laquelle sera envoyée la réponse
.CC = sAdresseResp
.BCC = ""
.Subject = sSujet 'sujet du message
.TextBody = sBody 'corps du message
.AddAttachment Fichier 'fichier joint
.DSNOptions = 14 'confirmation demandée dans tous les cas (voir ci-dessous avec 14 8 + 4 + 2)
' (0=pas réponse ; 2=rapport si échec ; 4=rapport si réussi ; 8=rapport si délai)

' pour demander des confirmations de réception ou d'envoi :
.Fields("urn:schemas:mailheader:return-receipt-to") = sAdresseRetour
.Fields("urn:schemas:mailheader:disposition-notification-to") = sAdresseRetour

' Configuration du serveur SMTP
schema = "http://schemas.microsoft.com/cdo/configuration/"
flds.Item(schema & "sendusing") = cdoSendUsingPort
flds.Item(schema & "smtpserver") = "mail.aviva.com"
flds.Item(schema & "smtpserverport") = 25
flds.Item(schema & "smtpauthenticate") = cdoAnonymous
flds.Item(schema & "smtpusessl") = False
flds.Update

' Update fields
.Fields.Update

' envoi
Set .Configuration = iConf
.Send

End With

End Sub
Le 25/07/2018 à 11:44

merci, déjà de la mise en page

Rechercher des sujets similaires à "envoie mail partir nom prenom"