Envoi mail VBA avec pj différente à chaque destinataire

Le 06/01/2022 à 17:40
21variable-fixe.xlsm (73.95 Ko)
Bonjour,
je cherche à envoyer des mails en automatique via vba.
j'ai déjà un début de code mais je bloque sur une partie qui n'est jamais fixe.
Mes clients doivent recevoir des fichiers de retour intitulé "fichierA", "FichierB", cette nomination est toujours fixe.
Par contre devant l'intitulé, il y a une partie qui sera toujours variable: ex: Jean Louis_FichierA.
A chaque fois que je dois faire un retour d'un suivi, le nom prénom devant l'underscore changera et je ne saurai jamais quel nom sera présent.
Auriez-vous une idée pour que je puisse quand même envoyer ce mail en automatique?
merci.
Le 06/01/2022 à 17:55

bonjour,

une proposition non testée

Sub Envoi()

    Dim LeMail As Object

    With Sheets("Paramètres")
        xSujet = .[B3]
        xBody = .[B4]
        xchemin = .[B7]
    End With

    Set OutlookApp = CreateObject("Outlook.Application")

    For Each xClasseur In Range("tblBase[Laiterie]")
        xLig = xLig + 1
        xfichier = Range("tblBase[Laiterie]")(xLig, 1)

        Set LeMail = OutlookApp.CreateItem(0)

        With LeMail
            .To = xTo
            .CC = xCc
            .Subject = xSujet
            .Body = xBody
            If xfichier <> "" Then 

                'met en annexe tous les fichiers trouvés dont le nom se termine par xfichier.pdf
                nf = Dir(xchemin & "\*" & xfichier & ".pdf")
                Do While nf <> ""
                    .Attachments.Add xchemin & "\" & nf
                    nf = Dir()
                Loop

            End If
            .Display
            '.Send
        End With
    End If
Next xClasseur

' Effacer les variables objet pour libérer la mémoire
Set LeMail = Nothing

MsgBox "mail envoyé"
End Sub
Le 06/01/2022 à 18:10

Bonjour Jumarin,

Voici un code qui devrait fonctionner

Sub Envoi()
  Dim OutlookApp As Object
  Dim LeMail As Object
  Dim xTo As String, xCC As String
  Dim Cel As Range
  Dim xSujet As String, xBody As String
  Dim xChemin As String, xFichier As String
  Dim sNomFic As String

  With Sheets("Paramètres")
    xSujet = .[B3]
    xBody = .[B4]
    xChemin = .[B7]
  End With

  Set OutlookApp = CreateObject("Outlook.Application")
  ' Pour chaque cellule de la plage
  For Each Cel In Range("tblBase[Laiterie]")
    ' Récupéré le nom que doit contenir le fichier
    xFichier = Cel
    ' Vérifier si existe un fichier
    If FichierExiste(xChemin & "\*" & xFichier & ".pdf") = True Then
      xTo = Range("tblBase[Mail]")(xLig, 1)
      xCC = ""
      Set LeMail = OutlookApp.CreateItem(0)
      With LeMail
        .Display
        .To = xTo
        .CC = xCC
        .Subject = xSujet
        ' Si une signature existe
        .Body = xBody & .Body
        ' Pour chaque fichier à attacher
        sNomFic = Dir(xChemin & xFichier)
        Do While sNomFic <> ""
          .Attachments.Add sNomFic
          sNomFic = Dir()
        Loop
        '.Send
      End With
    End If
  Next Cel
  ' Effacer les variables objet pour libérer la mémoire
  Set LeMail = Nothing
  MsgBox "mail envoyé"
End Sub

A+

Edit : oups, salut h2so4 même idée apparemment

Le 06/01/2022 à 18:28

bonsoir Brunom45,

salut h2so4 même idée apparemment

sauf que ma macro envoie un mail même quand il n'y a pas de fichier à envoyer, ce qui ne me semble pas correct. Donc ta solution me paraît adéquate.

Le 07/01/2022 à 09:50

Bonjour ,

merci à h2so4 et Bruno45.

J'ai testé la macro de Bruno 45, et ça fonctionne presque mais le système ne vient pas chercher mes destinataires

je suis débutant en vba, désolé

image
Le 07/01/2022 à 10:26

bonjour,

une correction (non testée)

Sub Envoi()

    Dim LeMail As Object

    With Sheets("Paramètres")
        xSujet = .[B3]
        xBody = .[B4]
        xchemin = .[B7]
    End With

    Set outlookapp = CreateObject("Outlook.Application")

    For Each xClasseur In Range("tblBase[Laiterie]")
        xLig = xLig + 1
        xfichier = Range("tblBase[Laiterie]")(xLig, 1)

        If xfichier <> "" Then

            'met en annexe tous les fichiers trouvés dont le nom se termine par xfichier.pdf
            nf = Dir(xchemin & "\*" & xfichier & ".pdf")

            mailacreer = True
            Do While nf <> ""
                If mailacreer Then
                    Set LeMail = outlookapp.CreateItem(0)
                    mailacreer = False
                    LeMail.To = xto
                    LeMail.CC = xCc
                    LeMail.Subject = xSujet
                    LeMail.Body = xBody
                End If
                LeMail.Attachments.Add xchemin & "\" & nf
                nf = Dir()
            Loop

        End If
        LeMail.Display
        'lemail.Send
    Next xClasseur

    ' Effacer les variables objet pour libérer la mémoire
    Set LeMail = Nothing

    MsgBox "mails envoyés"
End Sub
Le 07/01/2022 à 14:17
image image
Le 07/01/2022 à 14:18

Tu vas en avoir marre de moi, mais j'ai un pb lorsque j'envoie le mail.

Peux-tu m'aider?

Le 07/01/2022 à 14:26

en fait, j'ai remarqué qu'il bloque quand dans mon tableau, il passe sur un destinataire et qu'il n'a pas de fichier à recevoir.

Le 07/01/2022 à 14:49

bonjour,

désolé, problème de neurones mal embouchés. Nouvelle version (testée cette fois-ci)

Sub Envoi()

    Dim LeMail As Object

    With Sheets("Paramètres")
        xSujet = .[B3]
        xBody = .[B4]
        xchemin = .[B7]
    End With

    Set outlookapp = CreateObject("Outlook.Application")

    For Each xClasseur In Range("tblBase[Laiterie]") 'prendre chaque client
        xLig = xLig + 1
        xfichier = Range("tblBase[Laiterie]")(xLig, 1) 'nom générique du fichier pour ce client

        If xfichier <> "" Then 'on ne fait rien si le nom générique n'est pas rempli

            'met en annexe tous les fichiers trouvés dont le nom se termine par xfichier.pdf
            nf = Dir(xchemin & "\*" & xfichier & ".pdf") 'on vérifie s'il existe un fichier
            If nf <> "" Then 'si oui
                Set LeMail = outlookapp.CreateItem(0) 'on crée un message
                xTo = Range("tblBase[Mail]")(xLig, 1)
                xCC = ""
                LeMail.To = xTo
                LeMail.CC = xCC
                LeMail.Subject = xSujet
                LeMail.Body = xBody
                Do While nf <> "" ' tant qu'il y a des fichiers dont le nom se termine par xfichier & ".pdf"
                    LeMail.Attachments.Add xchemin & "\" & nf
                    nf = Dir()
                Loop
                LeMail.Display 'affichage du message
                'lemail.Send 'envoi du message
            End If
        End If
    Next xClasseur

    ' Effacer les variables objet pour libérer la mémoire
    Set LeMail = Nothing

    MsgBox "mails envoyés"
End Sub
Le 10/01/2022 à 11:14

Bonjour

Merci beaucoup @H2SO4, ça fonctionne nickel.

Rechercher des sujets similaires à "envoi mail vba differente chaque destinataire"