Envoi email automatique

Le 09/07/2019 à 10:59

Bonjour ,

J'ai un fichier excel qui contient plusieurs onglet ,, chaque onglet est une agence a qui je veux envoyer un e mail

est ce que c possible d'automatisé tout ça .

16agence-v4.xlsm (877.42 Ko)

Le 09/07/2019 à 11:14

Bonjour,

oui c'est possible mais il manque beaucoup de précisions (as-tu outlook ? contenu du mail? adresse mail ? ect ...)

Fait attention à bien anonymiser ton fichier avant de le poster sur un forum !

Cordialement

Le 12/07/2019 à 14:58

vince1512 a écrit :
Bonjour,
oui c'est possible mais il manque beaucoup de précisions (as-tu outlook ? contenu du mail? adresse mail ? ect ...)
Fait attention à bien anonymiser ton fichier avant de le poster sur un forum !
Cordialement

oui j'ai outlook pour le contenu c'est les onglet pour chaque onglet c'est une adresse mail . tu veux comme quoi comme détails

Le 12/07/2019 à 21:58

Bonsoir abdernino,

voici le code et un fichier exemple, j'ai mis dans chaque onglet l'adresse email de l'agence dans la cellule "B1":

Sub EnvoiOnglet()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String

    Dim OutApp As Object
    Dim OutMail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False

    End With

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" Then

            Set Sourcewb = ActiveWorkbook

            ws.Copy
            Set Destwb = ActiveWorkbook

            FileExtStr = ".xlsx": FileFormatNum = 51

            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next

                Destinataire = Sheets(1).Range("B1")
                Sujet = Sheets(1).Range("F2")

                With OutMail
                    .to = Destinataire
                    .CC = ""
                    .BCC = ""
                    .Subject = Sujet
                    .Body = "Veuillez trouver...."
                    .Attachments.Add Destwb.FullName
                    .display
                    '.Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With

            Kill TempFilePath & TempFileName & FileExtStr
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Cordialement

15agence-v4-forum.xlsm (499.46 Ko)

Le 13/07/2019 à 22:27

Bonsoir,

Je m'excuse, j'ai téléchargé le mauvais fichier avec une erreur dans le code . Remplacer la ligne:

Kill TempFilePath & TempFileName & FileExtStr

avec

Kill TempFileName & FileExtStr

Le 14/07/2019 à 11:52

Sequoyah a écrit :
Bonsoir,
Je m'excuse, j'ai téléchargé le mauvais fichier avec une erreur dans le code . Remplacer la ligne:
Kill TempFilePath & TempFileName & FileExtStr
avec
Kill TempFileName & FileExtStr

Bonjour et merci pour ton aide

1- si je doit insérer un texte avec le tableau comment faire .

2- la macro est ce que je dois l’insérer dans un bouton .

Le 14/07/2019 à 19:51

Salut abdernino,

Je joins une nouvelle version du fichier avec un bouton pour lancer automatiquement la macro.

En ce qui concerne le texte de l'e-mail, tu peux personnaliser cette partie du code en changeant les mots entre guillemets (en rouge), & vbNewLine & indique un retour chariot :

.Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."

14agence-v4-forum2.xlsm (503.57 Ko)

Le 14/07/2019 à 20:25

Sequoyah a écrit :
Salut abdernino,
Je joins une nouvelle version du fichier avec un bouton pour lancer automatiquement la macro.
En ce qui concerne le texte de l'e-mail, tu peux personnaliser cette partie du code en changeant les mots entre guillemets (en rouge), & vbNewLine & indique un retour chariot :
.Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."

Merci beaucoup

est ce qu'il envoie automatiquement de ma boite qui est déjà installé.et pour les adresse est ce que peut la la caché

Le 15/07/2019 à 22:09

Salut abdernino,

je joins une nouvelle version du fichier que j'ai créé, j'ai ajouté un onglet pour les adresses e-mail et donc plus besoin de les écrire sur chaque feuille, Il suffit de les mettre à jour une fois pour toujour.

Voici le code:

Sub EnvoiOnglet3()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tableau As Variant
    Dim i      As Integer, k As Integer, LastRow As Integer
    Dim aKey   As String
    Dim aValue As String
    Dim Dict   As Object
    Dim wsMail As Worksheet
    Dim Adresse As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False

    End With

    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row

    Tableau = wsMail.Range("A2:B" & LastRow)

    Set Dict = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Tableau)
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then

            Set Sourcewb = ActiveWorkbook

            ws.Copy
            Set Destwb = ActiveWorkbook

            FileExtStr = ".xlsx": FileFormatNum = 51

            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next

                Adresse = Sheets(1).Range("C6").Value
                Destinataire = Dict.Item(Adresse)
                Sujet = Sheets(1).Range("F2")

                With OutMail
                    .To = Destinataire
                    .CC = ""
                    .BCC = ""
                    .Subject = Sujet
                    .Body = "Bonjour," & vbNewLine & "Veuillez trouver....," & vbNewLine & "Cordialement."
                    .Attachments.Add Destwb.FullName
                    .display
                    '.Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With

            Kill TempFileName & FileExtStr
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Pour l'envoi automatique sans afficher le message (une fois la phase de test terminée) on peut commenter la ligne de code

'.Display

et décommenter

.Send

A' bientôt

24agence-v4-forumv2.xlsm (503.43 Ko)

Le 16/07/2019 à 10:44

Bonjour , est ce que possible de modifié le texte en dehors de la macro

Le 16/07/2019 à 18:52

Bonjour,

tu doix expliquer plus précisément ce que tu veux faire. Le texte est le même pour chaque message? On peut écrire ce texte dans un cellule (par exemple, comme on fait dans mon code pour le sujet de l'email, toujours dans la même position - Sheets(1).Range("F2")).

Le 16/07/2019 à 19:27

Je voudrais écrire le texte dans une feuille , pas dans la macro pour pouvoir mettre un paragraphe en rouge par exemple

Le 18/07/2019 à 20:52

Bonsoir,

pour la mise en forme du texte du message, je pense qu'il faut tout de même utiliser les balises HTML dans le code de la macro, voici une nouvelle proposition:

Sub EnvoiOngletHTML()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tableau As Variant
    Dim i      As Integer, k As Integer, LastRow As Integer
    Dim aKey   As String
    Dim aValue As String
    Dim Dict   As Object
    Dim wsMail As Worksheet
    Dim Adresse As String
    Dim strBody As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False

    End With

    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row

    Tableau = wsMail.Range("A2:B" & LastRow)

    Set Dict = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Tableau)
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then

            Set Sourcewb = ActiveWorkbook

            ws.Copy
            Set Destwb = ActiveWorkbook

            FileExtStr = ".xlsx": FileFormatNum = 51

            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next

                strBody = "Bonjour, <p>" & _
                          "Veuillez trouver...." & "<br>" & _
                          "<font color=red> Merci de bien vouloir...., " & "</font color=red>" & "<br>" & "Cordialement.</a></font>"

                Adresse = Sheets(1).Range("C6").Value
                Destinataire = Dict.Item(Adresse)
                Sujet = Sheets(1).Range("F2")

                With OutMail
                    .To = Destinataire
                    .CC = ""
                    .BCC = ""
                    .Subject = Sujet
                    .HTMLBody = strBody
                    .Attachments.Add Destwb.FullName
                    .display
                    '.Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With

            Kill TempFileName & FileExtStr
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Le 30/07/2019 à 20:43

Bonjour,

1- je voudrais rédiger le message sans accéder a la macro, et est ce que c'est possible de rajouter au mail agence qui mettre en copie .

Merci

Le 31/07/2019 à 23:06

Sequoyah a écrit :

Bonsoir,

pour la mise en forme du texte du message, je pense qu'il faut tout de même utiliser les balises HTML dans le code de la macro, voici une nouvelle proposition:

Sub EnvoiOngletHTML()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tableau As Variant
    Dim i      As Integer, k As Integer, LastRow As Integer
    Dim aKey   As String
    Dim aValue As String
    Dim Dict   As Object
    Dim wsMail As Worksheet
    Dim Adresse As String
    Dim strBody As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False

    End With

    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row

    Tableau = wsMail.Range("A2:B" & LastRow)

    Set Dict = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Tableau)
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then

            Set Sourcewb = ActiveWorkbook

            ws.Copy
            Set Destwb = ActiveWorkbook

            FileExtStr = ".xlsx": FileFormatNum = 51

            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next

                strBody = "Bonjour, <p>" & _
                          "Veuillez trouver...." & "<br>" & _
                          "<font color=red> Merci de bien vouloir...., " & "</font color=red>" & "<br>" & "Cordialement.</a></font>"

                Adresse = Sheets(1).Range("C6").Value
                Destinataire = Dict.Item(Adresse)
                Sujet = Sheets(1).Range("F2")

                With OutMail
                    .To = Destinataire
                    .CC = ""
                    .BCC = ""
                    .Subject = Sujet
                    .HTMLBody = strBody
                    .Attachments.Add Destwb.FullName
                    .display
                    '.Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With

            Kill TempFileName & FileExtStr
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Je voudrais pour chaque adress rajouter qui mettre en copie.

Pour le message le rédiger en dehors de la macro

Le 01/08/2019 à 18:23

Bonsoir abdernino,

voici la dernière version du fichier et le code ci-dessous. J'ai mis le message à adapter divisé en quatre parties sur la Feuille Mail et j'ai ajouté une colonne avec les adresses auxquelles envoyer la copie:

Sub EnvoiOngletHTML2()

    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim ws     As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim Destinataire As String
    Dim Sujet  As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Tableau As Variant
    Dim i      As Integer, k As Integer, LastRow As Integer
    Dim aKey   As String
    Dim aValue As String
    Dim Dict   As Object
    Dim wsMail As Worksheet
    Dim Adresse As String
    Dim strBody As String
    Dim DestCopie As String
    Dim Intro  As String, TexteInit As String, TexteRouge As String, Salutation As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False

    End With

    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 1).End(xlUp).Row

    Intro = wsMail.Range("H2")
    TexteInit = wsMail.Range("H3")
    TexteRouge = wsMail.Range("H4")
    Salutation = wsMail.Range("H5")

    Tableau = wsMail.Range("A2:B" & LastRow)

    Set Dict = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Tableau)
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then

            Set Sourcewb = ActiveWorkbook

            ws.Copy
            Set Destwb = ActiveWorkbook

            FileExtStr = ".xlsx": FileFormatNum = 51

            TempFilePath = ThisWorkbook.Path
            TempFileName = ActiveSheet.Name

            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            With Destwb
                .SaveAs TempFileName & FileExtStr, FileFormat:=FileFormatNum
                On Error Resume Next

                strBody = Intro & "<p>" & _
                          TexteInit & "<br>" & _
                          "<font color=red>" & TexteRouge & "</font color=red>" & "<br>" & Salutation

                Adresse = Sheets(1).Range("C6").Value
                Destinataire = Dict.Item(Adresse)
                DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:C" & LastRow), 2, False)
                Sujet = Sheets(1).Range("F2")

                With OutMail
                    .To = Destinataire
                    .CC = DestCopie
                    .BCC = ""
                    .Subject = Sujet
                    .HTMLBody = strBody
                    .Attachments.Add Destwb.FullName
                    .display
                    '.Send
                End With
                On Error GoTo 0
                .Close savechanges:=False
            End With

            Kill TempFileName & FileExtStr
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

15agence-v4-3.xlsm (505.53 Ko)

Le 01/08/2019 à 19:50

Bonsoir ,

Merci beaucoup c'est parfait .

Adresse = Sheets(1).Range("C6").Value

Destinataire = Dict.Item(Adresse)

DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:D" & LastRow), 2, j'ai essayer de rajouter d'autre personne a mettre en copie dans la colonne D mais ca marche pas

Merci

Le 01/08/2019 à 20:37

Bonsoir Abdernino et merci pour ton retour,

on peut insérer plusieurs adresses dans la même cellule (colonne C), séparées par un point-virgule, par exemple mail1@mail.com; mail2@mail.com

Le 01/08/2019 à 20:59

Merci beaucoup pour ton aide.

une dernière petite question la dispatche ce fait que s'il y a des nombres ?

Le 01/08/2019 à 21:24

Bonsoir ,

Non maintenant çà marche très bien même si il y pas de nombre

Merci beaucoup

Rechercher des sujets similaires à "envoi email automatique"