Macro pour envoi de mail automatique

Bonjour,

Je dispose d'un fichier excel disposant d'une zone qui s'incrémente automatiquement d'une adresse mail via une fonction rechercheV.Le but étant de cliquer sur l'adresse mail pour ouvrir la messagerie et envoyer un mail à la personne désignée.

Pour optimiser mon fichier, je cherche une macro qui permettrai l'envoi d'un mail automatiquement (mail type paramétré auparavant) à la personne simplement en cliquant sur un bouton, ce qui supprimerait l'étape d'ouverture de la messagerie et de rédaction du mail.

Merci par avance de votre aide,

Bonjour,

Pour te donner une idée te poste un bout de code avec ajout de destinataire et de pièces jointe que j'ai fait pour l'envoi de mail.

Pour ma part je l'affiche avant de l'envoyer mais pour l'envoyer directement tu remplaces .Display par .Send.

La première partie du code concerne l'alimentation des destinataires du mail et l'avant dernière partie concerne l'ajout des pièces jointes récupérées dans un répertoire.

Sub AddRecipAttachDisplay(ContenuMail As String, b_action As Byte)

'appelle les sub qui remplisse les tableaux de recipients, ajoute conditionnelement la PJ puis affiche le message
'les tableaux sont : aRecipientsCC() & aRecipientsAA()

Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim lesRecipients As Outlook.Recipients
Dim objNamespace As Outlook.Namespace
Dim cell As Range
Dim i As Integer, j As Integer 'indice des tableaux récipients
Dim leRecipient As Outlook.Recipient
Dim bRecipientResolu As Boolean
Dim recupereNumRelance As Byte
Dim msg As String
Dim sObjet As String
Dim ObjPj As Outlook.Attachments
Dim sChaineDeRecherche As String
Dim sCheminPj As String 'stocke le nom de fichier renvoyé par DIR
Dim sCheminPjs() As String 'stocke dans un tableau le chemin des PJ (synthèses quanti + fichier remarques)
Dim iindiceCheminPjs As Integer
Dim bEstTrouveePj As Boolean

'on supprime les valeurs dans les tableaux car la procédure commence là
Erase aRecipientsAA()
Erase aRecipientsCC()

'on part du principe que les mails sont bons.
'bRecipientNonResolu sera mis à faux si un des mails n'est pas résolu
bRecipientResolu = True
recupereNumRelance = recupNumRelance

Select Case b_action
    Case 0
        sObjet = "Mise en ligne de questionnaire d'évaluation"
        Call alimenteTableauAvecRespEnseignement
        Call alimenteTableauAvecRespFormation

    Case 1
        sObjet = "Relance " & recupereNumRelance & " évaluation"
        If recupereNumRelance = 1 Or recupereNumRelance = 2 Then
      '      MsgBox IsArray(aRecipientsAA) & " " & IsEmpty(aRecipientsAA) '& " " & LBound(aRecipientsAA) & " " & UBound(aRecipientsAA)
'            Stop
            ReDim aRecipientsAA(1 To 1)
            aRecipientsAA(1) = sEmailChargeEvaluation
        ElseIf recupereNumRelance = 3 Then
            indiceCC = 1
            ReDim aRecipientsCC(1 To indiceCC)
            aRecipientsCC(indiceCC) = sEmailChargeEvaluation
            Call alimenteTableauAvecRespEnseignement
            Call alimenteTableauAvecRespFormation
        End If
    Case 2
            sObjet = "Résultats d'évaluation"
            indiceCC = 1
            ReDim aRecipientsCC(1 To indiceCC)
            aRecipientsCC(1) = sEmailRespService
            Call alimenteTableauAvecRespEnseignement
            Call alimenteTableauAvecRespFormation
            Call alimenteTableauAvecRespDep
            Call alimenteTableauAvecRespTypeDeFormation
End Select

On Error GoTo err_handlerGetObject:
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        'permet la connexion et la déconnexion
        Set objNamespace = olApp.GetNamespace("MAPI")
        'si on n'a pas d'instance d'Outlook ouverte, on se connecte avec le profil unite
        objNamespace.Logon Profile:="unite", NewSession:=True
    End If
    Set objMail = olApp.CreateItem(olMailItem)
    'Stop
    Set lesRecipients = objMail.Recipients

    With objMail
        Set ObjPj = objMail.Attachments
        For i = LBound(aRecipientsAA) To UBound(aRecipientsAA)
            'MsgBox aRecipientsAA(1)
            Set leRecipient = .Recipients.Add(aRecipientsAA(i))
            leRecipient.Type = olTo
        Next i
        For i = LBound(aRecipientsCC) To UBound(aRecipientsCC)
            Set leRecipient = .Recipients.Add(aRecipientsCC(i))
            leRecipient.Type = olCC
        Next i
        'on résout les adresses email
        lesRecipients.ResolveAll
        For Each leRecipient In lesRecipients
            If Not leRecipient.Resolved Then
                bRecipientResolu = False
                MsgBox "Le mail suivant est erroné " & leRecipient.name & vbCrLf & _
                        "Modifiez le et relancez la procédure"
            End If
        Next leRecipient

        'Récupération des résultats quantitatifs et qualitatifs à attacher aux emails
        If b_action = 2 Then
            sChaineDeRecherche = sCheminRepertoirePj & udtEnseignement.strMotCle & "*"
            sCheminPj = Dir(sChaineDeRecherche)
            If sCheminPj <> "" Then 'si DIR a ramené un nom de fichier
                bEstTrouveePj = True
                Do While sCheminPj <> "" 'tant que la chaîne vide n'est pas ramenée
                iindiceCheminPjs = iindiceCheminPjs + 1
                ReDim Preserve sCheminPjs(1 To iindiceCheminPjs)
                sCheminPjs(iindiceCheminPjs) = sCheminRepertoirePj & sCheminPj
                sCheminPj = Dir
                Loop
            End If
            If bEstTrouveePj Then
                For iindiceCheminPjs = LBound(sCheminPjs) To UBound(sCheminPjs)
                   ' MsgBox sCheminPjs(iindiceCheminPjs)
                    ObjPj.Add Source:=sCheminPjs(iindiceCheminPjs)
                Next iindiceCheminPjs
            Else
                MsgBox "Aucun résultat d'évaluation comportant le mot clé " & _
                Chr(34) & udtEnseignement.strMotCle & Chr(34) & " n 'a été trouvé dans " _
                & sCheminRepertoirePj
            End If
        End If
        'On Error GoTo err_handler:
        'MsgBox LBound(aRecipientsCC) > 0
        If Not bRecipientResolu Then Exit Sub
        'si une instance d'Outlook est ouverte, on envoie avec la boîte courante mais de "unite" de la part de l'utilisateur
        'courant
        .SentOnBehalfOfName = "Unite.Evaluation"
        .BodyFormat = olFormatHTML
        .HTMLBody = ContenuMail
        .Subject = sObjet
        .Display
    End With

Merci beaucoup, je vais essayer çà !