Macro envoi mails groupés

Le 01/06/2017 à 14:31

Bonjour,

J'ai une macro qui permet d'envoyer des mails individualisés à partir d'une liste que vous trouverez ci-joint. Le destinataire direct est en colonne C, et le destinataire en copie est en colonne D. L'emplacement du fichier est dans la colonne E.

Mon souci est que je veux qu'il récupère l'objet du mail depuis la colonne B.

Aussi, je souhaiterai que la macro enregistre les emails directement dans les brouillons à consulter plus tard, au lieu de me les ouvrir tous en même temps.

Enfin et si possible, y 'a t il une fonction facile pour changer la mise en forme du mail (body) ? J'ai trouvé un truc qui permet de mettre les espaces et retour en ligne, mais je me demandais s'il y avait plus facile.

Merci d'avance pour votre aide.

Cordialement,

Hajar

Sub test()

Dim LastRw As Long, i As Long

Dim nomFichier As String, destinataireTO As String, destinataireCC As String, cheminFichier As String

LastRw = Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row

For i = 4 To LastRw

nomFichier = Sheets("Feuil1").Range("A" & i)

destinataireTO = Sheets("Feuil1").Range("C" & i)

destinataireCC = Sheets("Feuil1").Range("D" & i)

cheminFichier = Sheets("Feuil1").Range("E" & i)

Envoyer_Mail_Outlook destinataireTO, destinataireCC, cheminFichier, nomFichier

Next

End Sub

Function Envoyer_Mail_Outlook(destTO As String, destCC As String, CheminFich As String, objet As String)

'Nécessite d'activer la référence "Microsoft Outlook Library"

Dim ObjOutlook As New Outlook.Application

Dim oBjMail

Dim Nom_Fichier As String

Set ObjOutlook = New Outlook.Application

Set oBjMail = ObjOutlook.CreateItem(olMailItem)

Nom_Fichier = fich

If objet = "" Then Exit Function

With oBjMail

.To = destTO ' le destinataire

.CC = destCC

.Subject = objet ' l'objet du mail

.Body = "Hello, " & vbCrLf & vbCrLf & vbCrLf & "Please find here attached the file to be used starting January 2017." 'le corps du mail ..son contenu

.Attachments.Add CheminFich

.Display ' Ici on peut supprimer pour l'envoyer sans vérification

' .Send

End With

' ObjOutlook.Quit

Set oBjMail = Nothing

Set ObjOutlook = Nothing

End Function

18liste-mailing-test-3.xlsm (38.09 Ko)
Le 03/06/2017 à 02:46

Bonjour,

Sub test()
Dim LastRw As Long, i As Long
Dim nomFichier As String, destinataireTO As String, destinataireCC As String, cheminFichier As String, obj As String
LastRw = Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Row
  For i = 4 To LastRw
    nomFichier = Sheets("Feuil1").Range("A" & i)
    obj = Sheets("Feuil1").Range("B" & i)
    destinataireTO = Sheets("Feuil1").Range("C" & i)
    destinataireCC = Sheets("Feuil1").Range("D" & i)
    cheminFichier = Sheets("Feuil1").Range("E" & i)
    Envoyer_Mail_Outlook destinataireTO, destinataireCC, cheminFichier, nomFichier, obj
  Next
End Sub

Function Envoyer_Mail_Outlook(destTO As String, destCC As String, CheminFich As String, objet As String)
'Nécessite d'activer la référence "Microsoft Outlook Library"
Dim ObjOutlook As New Outlook.Application
Dim oBjMail
Dim Nom_Fichier As String

    Set ObjOutlook = New Outlook.Application
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)

   Nom_Fichier = fich
    If objet = "" Then Exit Function
     With oBjMail
       .To = destTO      ' le destinataire
       .CC = destCC
       .Subject = objet ' l'objet du mail
       .Body = "Hello, " & vbCrLf & vbCrLf & vbCrLf & "Please find here attached the file to be used starting January 2017."  'le corps du mail ..son contenu
       .Attachments.Add CheminFich
       .Send
    End With
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
End Function
Le 06/06/2017 à 12:10

Bonjour

Merci pour la macro. Cependant y a une erreur à l'exécution "Erreur de compilation nombre d'arguments incorrect ou affectation de propriété incorrecte.."

Merci d'avance.

Cordialement,

Hajar

Le 06/06/2017 à 15:37

Merci pour la macro. Cependant y a une erreur à l'exécution "Erreur de compilation nombre d'arguments incorrect ou affectation de propriété incorrecte.."

l'erreur se produit sur quel ligne ?

Le 06/06/2017 à 15:45

premier paragraphe "Envoyer_Mail_Outlook" Destinataire...

Le 06/06/2017 à 16:38

avez-vous activer la référence "Microsoft Outlook Library" ?

si oui, exécuter la macro en mode pas à pas

et vérifier si chaque variable destinataireTO, destinataireCC, cheminFichier, nomFichier, obj est bien renseignée

Le 06/06/2017 à 17:07

oui la référence est bien activée, tous les champs sont renseignés, et quand je lance la macro pas à pas il s'arrête sur cette erreur

Le 06/06/2017 à 18:10

Bonjour Hajar,

voici la correction,

40hajar-liste-mailing-test-3.xlsm (40.95 Ko)
Le 06/06/2017 à 18:23

merci

j'ai testé ça bugait au niveau de la ligne "Display" à la fin pour vérifier le mail avant envoi

j'ai essayé de supprimer la ligne j'ai lancé la macro mais rien ne se passe...

merci d'avance pour votre aide

Le 06/06/2017 à 18:39

Bonjour,

pourquoi supprimer la ligne, c'est soit .Send ou .Display

vous devez laisser un des deux.

Le 07/06/2017 à 08:45

Bonjour,

La macro marche mais comme l'ancienne, c'est à dire je n'ai pas comme objet du mail ce que j'ai noté en colonne B mais le nom du fichier en colonne A. Et puis il ne m'enregistre pas les mails directement dans mes brouillons mais les ouvre directement pour vérification avant envoi, comme l'ancienne version...

Merci d'avance pour votre aide si vous arrivez à me trouver une solution.

Cordialement,

Hajar

Le 07/06/2017 à 14:50

Bonjour,

je n'ai pas comme objet du mail ce que j'ai noté en colonne B mais le nom du fichier en colonne A

vous pouvez modifier les colonnes selon la disposition de vos données, voir les lignes suivante.

    nomFichier = Sheets("Feuil1").Range("A" & i)
    destinataireTO = Sheets("Feuil1").Range("C" & i)
    destinataireCC = Sheets("Feuil1").Range("D" & i)
    cheminFichier = Sheets("Feuil1").Range("E" & i)
    obj = Sheets("Feuil1").Range("B" & i)

il ne m'enregistre pas les mails directement dans mes brouillons mais les ouvre directement pour vérification avant envoi,

pour ce qui est de l'enregistrement dans les brouillons, sans l'envoi du mail, enlever (.Send et/ou .Display) et mettre .Save à la place

Le 07/06/2017 à 15:26

c'est trop cool ! ça marche ! merci beaucoup !!

Le 07/06/2017 à 16:11

Bonjour je suis débutante dans ce langage et j'ai un petit soucis pour en créer une répond a mon besoin.

Je dois créer une maccro qui envoi 1 mail a deux personnes si dans mon inventaire des articles arrivent à 1.

Dans mon mail il doit avoir le contenu de ma cellule A qui est a la même ligne que la cellule D=1.

Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2
Const cdoAnonymous = 0
' Use basic (clear-text) authentication.
Const cdoBasic = 1
' Use NTLM authentication
Const cdoNTLM = 2 'NTLM

Public Sub SendEmail()
    Dim imsg As Object

    Dim iconf As Object
    Dim flds As Object
    Dim schema As String

    Set imsg = CreateObject("CDO.Message")
    Set iconf = CreateObject("CDO.Configuration")
    Set flds = iconf.Fields

    ' send one copy with SMTP server (with autentication)
    schema = "http://schemas.microsoft.com/cdo/configuration/"
    flds.Item(schema & "sendusing") = cdoSendUsingPort
    flds.Item(schema & "smtpserver") = ".......ca"
    flds.Item(schema & "smtpserverport") = 25
    flds.Item(schema & "smtpauthenticate") = cdoBasic
    flds.Item(schema & "smtpusessl") = False
    flds.Update

    With imsg
        .To = "quelqu'un"
        .From = "moi-même"
        .Subject = "Quantité manquante"
        .HTMLBody = "Un article de l'inventaire est à 1 il faudrait en commander d'autres"
        Set .Configuration = iconf
       .Send

    End With

    Set iconf = Nothing
    Set imsg = Nothing
    Set flds = Nothing

End Sub
Rechercher des sujets similaires à "macro envoi mails groupes"