Envoi de plage de cellule dans un mail

Le 09/10/2018 à 10:42

Bonjour à tous,

J'ai besoin d'aide :'(.

Je travaille actuellement sur une refonte complète d'un de mes outils, et j'avais pour ambition un envoi de mail automatisé afin de relancer des fournisseurs.

Je ne peux malheureusement pas mettre en PJ le fichier par souci de confidentialité, mais je vais insérer un bout de code :

Sub Tri()

    ' Déclarer des variables
    Dim Critere As String
    Dim RSource As Range
    Dim RDest As Range
    Dim RTitres As Range
    Dim RColonneUtilisateur As Range
    Dim i As Long
    Dim DerLig As Long
    Dim DerCol As Long
    Dim DerLigDest As Long
    Dim IndiceColonne As Long
    Dim Feuilles As Worksheet

    ' On supprime les feuilles inutiles
    SuppressionFeuilles

    ' On va affecter des valeurs par défaut
    DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
    DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column

    ' On affecte les titres pour pouvoir les copier dans les feuilles créées
    Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
    Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
    IndiceColonne = RColonneUtilisateur.Column

    ' Désactiver l'affichage à l'écran
    Application.ScreenUpdating = False

    ' On trie selon la colonne choisie
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' On parcourt les lignes
    For i = 2 To DerLig

        ' On récupère le Critere de la ligne
        Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)

        If Critere <> "" Then

            ' On va vérifier si la feuille existe
            ' Si elle n'existe pas
            If VerifFeuille(Critere) = False Then

                ' On créé la feuille en dernier
                Sheets.Add after:=Sheets(Sheets.Count)

                ' On la nomme
                Sheets(Sheets.Count).Name = Critere

                ' On copie les titres
                Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)

                RDest.Value = RTitres.Value

                ' Mise en forme
                With RDest
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With

            End If

        ' On cherche la ligne où l'on doit copier dans la feuille de destination
        DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1

        ' On déclare le range source de la ligne à copier
        Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)

        ' On déclare le range où il faut copier la source
        Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)

        ' On copie la ligne
        RDest.Value = RSource.Value

        End If

    Next i

    ' Pour chaque feuille dans la collection des feuilles
    For Each Feuilles In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then

            ' On prend les colonnes du range des titres et on met leur taille en autofit
            Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol).Address).Columns.EntireColumn.AutoFit

        End If

    Next

    ' On se remet sur la feuille du début
    Sheets("Suivi").Activate

    ' On remet le tri d'origine
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True

    ' Pour chaque feuille dans la collection des feuilles
    For Each Feuilles In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then

            DerLig = Feuilles.Cells(Rows.Count, 1).End(xlUp).Row
            DerCol = Feuilles.Cells(1, Columns.Count).End(xlToLeft).Column

            ' Envoi de mails
            Dim OutApp As Object
            Dim OutMail As Object
            Dim Corps As String
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)

            ' Corps du mail
            Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous :<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"

            On Error Resume Next
            With OutMail

                ' Expéditeur
                .SentOnBehalfOfName = "monmail@mail.fr"
                .To = Feuilles.Cells(2, 12).Value
                .Display

                ' En copie
                '.BCC =

                ' Objet du mail
                .Subject = "Relance " & Feuilles.Cells(2, 19).Value
                .HTMLBody = Corps & .HTMLBody

                ' Envoi du mail, ajouter une apostrophe avant pour le désactiver
                '.Send
            End With
            On Error GoTo Oups
            Set OutMail = Nothing
            Set OutApp = Nothing
Oups: Resume Next

        End If

    Next

End Sub

Ce bout de code me permet de créer une feuille par mail à relancer, puis à envoyer un mail pour chaque feuille aux personnes correspondantes.

Mon souci est que je n'arrive pas à intégrer le contenu de ma feuille (que ce soit sous forme de plage de cellules, de feuille ou je ne sais quoi) et que dans l'idéal il faudrait soit la plage directement dans le mail ou en PJ, de sorte que le fournisseur puisse ajouter ses commentaires dans celle-ci.

J'avais espéré créer une variable range en utilisant DerLig et DerCol en Range(Cells(1,1).Address,Cells(DerLig,DerCol).Address) et intégrer cette variable directement dans le corps mais ça ne fonctionne pas...

Quelqu'un aurait une solution?

Merci d'avance!

Le 09/10/2018 à 11:26

Bonjour,

Utilise la balise code </> car là ce n'est pas trop lisible.

Une solution est d'utiliser sendkeys

    Range("A:A").Copy
    email.display
    Application.Wait (Now + TimeValue("0:00:01"))
    SendKeys "^v", True
    Application.CutCopyMode = False
16envoi-email-copie-sendkeys.xlsm (14.04 Ko)
Le 09/10/2018 à 11:32

Désolé! Je ferai ça la prochaine fois .

Pas mal ça! Je vais essayer et je reviens donner le résultat!

Merci pour ton aide!

Le 09/10/2018 à 11:35

Pour simplifier, je mets aussi le laïus (Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous :) dans la feuille excel et je copie le tout comme l'exemple !

Le 09/10/2018 à 16:49

Bonjour,

ci-dessous un code permettant d'afficher une plage de cellules sous le corps du message

Sub Envoi_Mail()

    ' Définition des variables
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim feuille As Worksheet, plage_feuille As Range

    '// assignation application Outlook
    Set OL = CreateObject("Outlook.Application")

    '// Pour chaque feuille dans la collection des feuilles
    For Each feuille In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If feuille.Name <> "Menu" And feuille.Name <> "Suivi" And feuille.Name <> "Annuaire" Then

            With feuille
                ' Corps du mail
                Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"

                ' plage feuille à envoyer
                Set plage_feuille = .Range("A1:I20")

                ' Assignation des objets
                Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor

                ' Création Email et envoi
                With myItem

                    ' Expéditeur, Destinataire, Sujet, Corps
                    .SentOnBehalfOfName = "xxxxxxxxx@domaine.fr"
                    .To = feuille.Cells(2, "L").Value
                    .Subject = "Relance " & feuille.Cells(2, "S").Value
                    .HTMLBody = Corps
                    .Display

                    ' Copie de la plage
                    plage_feuille.Copy
                    Set rng = wDoc.Content
                    rng.InsertParagraphAfter
                    rng.Move 4, 1
                    rng.Paste
                    rng.Move 4

                    ' Envoi
                    .Send
                End With

                ' désassignation des objets
                Set myItem = Nothing: Set wDoc = Nothing
            End With

        End If
    Next feuille

    '// désassignation application Outlook
    Set OL = Nothing
End Sub
Le 16/10/2018 à 10:49

Bonjour thev,

En utilisant ta méthode, je suis arrivé à quelque chose d'assez satisfaisant!

Voici mon bout de code modifié avec tes éléments :

Sub testmail()

    ' Déclarer des variables
    Dim Critere As String
    Dim RSource As Range
    Dim RDest As Range
    Dim RTitres As Range
    Dim RColonneUtilisateur As Range
    Dim PlageEnvoi As Range
    Dim i As Long
    Dim DerLig As Long
    Dim DerCol As Long
    Dim DerLigDest As Long
    Dim IndiceColonne As Long
    Dim Feuilles As Worksheet

    ' On supprime les feuilles inutiles
    SuppressionFeuilles

    ' On va affecter des valeurs par défaut
    DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
    DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column

    ' On affecte les titres pour pouvoir les copier dans les feuilles créées
    Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
    Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
    IndiceColonne = RColonneUtilisateur.Column

    ' Désactiver l'affichage à l'écran
    Application.ScreenUpdating = False

    ' On trie selon la colonne choisie
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' On parcourt les lignes
    For i = 2 To DerLig

        ' On récupère le Critere de la ligne
        Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)

        If Critere <> "" Then

            ' On va vérifier si la feuille existe
            ' Si elle n'existe pas
            If VerifFeuille(Critere) = False Then

                ' On créé la feuille en dernier
                Sheets.Add after:=Sheets(Sheets.Count)

                ' On la nomme
                Sheets(Sheets.Count).Name = Critere

                ' On copie les titres
                Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)

                RDest.Value = RTitres.Value

                ' Mise en forme
                With RDest
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With

            End If

        ' On cherche la ligne où l'on doit copier dans la feuille de destination
        DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1

        ' On déclare le range source de la ligne à copier
        Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)

        ' On déclare le range où il faut copier la source
        Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)

        ' On copie la ligne
        RDest.Value = RSource.Value

        End If

    Next i

    ' Pour chaque feuille dans la collection des feuilles
    For Each Feuilles In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then

            ' On ajoute la colonne Commentaire
            Columns(12).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Cells(1, 12).Value = "Commentaire"

            ' On prend les colonnes du range des titres et on met leur taille en autofit
            Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol + 1).Address).Columns.EntireColumn.AutoFit

        End If

    Next

    ' On se remet sur la feuille du début
    Sheets("Suivi").Activate

    ' On remet le tri d'origine
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True

    ' Définition des variables
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim Feuille As Worksheet, PlageFeuille As Range

    '// assignation application Outlook
    Set OL = CreateObject("Outlook.Application")

    '// Pour chaque feuille dans la collection des feuilles
    For Each Feuille In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then

            With Feuille
                ' Corps du mail
                Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous,<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"

                DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
                DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column

                ' plage feuille à envoyer
                Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).Address)

                ' Assignation des objets
                Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor

                ' Création Email et envoi
                With myItem

                    ' Expéditeur, Destinataire, Sujet, Corps
                    .SentOnBehalfOfName = "monmail@mail.fr"
                    .To = Feuille.Cells(2, 13).Value
                    .Subject = "Relance " & Feuille.Cells(2, 20).Value
                    .HTMLBody = Corps & .HTMLBody

                    .Display

                    ' Copie de la plage
                    PlageFeuille.Copy
                    Set rng = wDoc.Content
                    rng.InsertParagraphAfter
                    rng.Move 4, 1
                    rng.Paste
                    rng.Move 4

                    ' Envoi
                    '.Send
                End With

                ' désassignation des objets
                Set myItem = Nothing: Set wDoc = Nothing
            End With

        End If
    Next Feuille

    '// désassignation application Outlook
    Set OL = Nothing

End Sub

Ça fonctionne très bien, mon mail s'affiche avec le contenu voulu. Par contre, je n'avais pas précisé que la signature par défaut de l'utilisateur devait s'insérer en fin de mail, d'où le

.HTMLBody = Corps & .HTMLBody.

Le souci maintenant, c'est que forcément, la plage de cellule s'insère en fin de mail, donc après ma signature.

J'aurais voulu qu'elle s'insère entre

Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous,

et

Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.

J'ai essayé de déplacer le HTMLBody après le display ou de le diviser en deux pour avoir d'un côté le format et de l'autre le corps du mail mais ça ne fonctionne pas. J'ai l'impression qu'il faut que le format soit géré avant de display le mail. Et même si j'arrivais à séparer tout ça, j'imagine que la plage ne se mettrait pas non plus où je veux...

En tout cas merci pour l'aide, j'ai déjà bien avancé grâce à vous! Ne me reste plus que le détail du positionnement de ma plage de cellule et l'affaire sera bouclée .

Un grand merci!

Le 16/10/2018 à 16:50

Bonjour,

Ce nouveau code devrait résoudre ton problème de signature :

    '.....................................................................

    ' Définition des variables
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim Feuille As Worksheet, PlageFeuille As Range

    '// assignation application Outlook
    Set OL = CreateObject("Outlook.Application")

    '// Pour chaque feuille dans la collection des feuilles
    For Each Feuille In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then

            With Feuille

                DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
                DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column

                ' plage feuille à envoyer
                Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).Address)

                ' Assignation des objets
                Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor

                ' Création Email et envoi
                With myItem

                    ' Expéditeur, Destinataire, Sujet
                     .SentOnBehalfOfName = "monmail@mail.fr"
                    .To = Feuille.Cells(2, 13).Value
                    .Subject = "Relance " & Feuille.Cells(2, 20).Value
                    .Display

                    Set rng = wDoc.Content

                    ' Corps du mail
                    rng.InsertParagraphBefore
                    rng.Move 4, -1
                    rng.InsertAfter vbNewLine & "Bonjour," & vbNewLine
                    rng.InsertAfter vbNewLine & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :" & vbNewLine
                    rng.InsertAfter vbNewLine & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison." & vbNewLine
                    rng.InsertAfter vbNewLine & "Restant à votre disposition pour toute information complémentaire," & vbNewLine

                    ' Police du corps du mail
                    With rng.Font
                        .Name = "Helvetica"
                        .Size = 12
                        .Color = 16711680
                    End With

                    ' Copie de la plage
                    rng.InsertParagraphAfter
                    rng.Move 4, 1
                    PlageFeuille.Copy
                    rng.Paste
                    rng.Move 4

                    ' Envoi
                    .Send
                End With

                ' désassignation des objets
                Set myItem = Nothing: Set wDoc = Nothing
            End With

        End If
    Next Feuille

    '// désassignation application Outlook
    Set OL = Nothing

End Sub
Le 16/10/2018 à 18:13
Steelson a écrit :

Une solution est d'utiliser sendkeys

J'avais préconisé SendKeys, mais j'écris aussi parfois en html dans le VBA

Je dois aussi avoir un module qui crée le html en fonction de la zone (je vais rechercher)

18envoi-email-htmlbody.xlsm (15.33 Ko)
Le 18/10/2018 à 08:42

Waouh... Merci thev!

Je viens de faire un test rapide et ça fonctionne!

Je vais modifier tout ça pour faire les finitions et je reviens .

Edit : C'est parfait :O. Voici mon code modifié au cas où ça pourrait servir à quelqu'un :

Sub Tri()

    ' Déclarer des variables
    Dim Critere As String
    Dim RSource As Range
    Dim RDest As Range
    Dim RTitres As Range
    Dim RColonneUtilisateur As Range
    Dim PlageEnvoi As Range
    Dim i As Long
    Dim DerLig As Long
    Dim DerCol As Long
    Dim DerLigDest As Long
    Dim IndiceColonne As Long
    Dim Feuilles As Worksheet

    ' On supprime les feuilles inutiles
    SuppressionFeuilles

    ' On va affecter des valeurs par défaut
    DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
    DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column

    ' On affecte les titres pour pouvoir les copier dans les feuilles créées
    Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
    Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
    IndiceColonne = RColonneUtilisateur.Column

    ' Désactiver l'affichage à l'écran
    Application.ScreenUpdating = False

    ' On trie selon la colonne choisie
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' On parcourt les lignes
    For i = 2 To DerLig

        ' On récupère le Critere de la ligne
        Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)

        If Critere <> "" Then

            ' On va vérifier si la feuille existe
            ' Si elle n'existe pas
            If VerifFeuille(Critere) = False Then

                ' On créé la feuille en dernier
                Sheets.Add after:=Sheets(Sheets.Count)

                ' On la nomme
                Sheets(Sheets.Count).Name = Critere

                ' On copie les titres
                Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)

                RDest.Value = RTitres.Value

                ' Mise en forme
                With RDest
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With

            End If

        ' On cherche la ligne où l'on doit copier dans la feuille de destination
        DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1

        ' On déclare le range source de la ligne à copier
        Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)

        ' On déclare le range où il faut copier la source
        Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)

        ' On copie la ligne
        RDest.Value = RSource.Value

        End If

    Next i

    ' Pour chaque feuille dans la collection des feuilles
    For Each Feuilles In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then

            ' On ajoute la colonne Commentaire
            Feuilles.Columns(12).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Feuilles.Cells(1, 12).Value = "Commentaire"

            ' On prend les colonnes du range des titres et on met leur taille en autofit
            Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol + 1).Address).Columns.EntireColumn.AutoFit

        End If

    Next

    ' On se remet sur la feuille du début
    Sheets("Suivi").Activate

    ' On remet le tri d'origine
    Sheets("Suivi").Sort.SortFields.Clear
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Suivi").Sort
        .SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.ScreenUpdating = True

' Définition des variables
    Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
    Dim Feuille As Worksheet, PlageFeuille As Range

    '// assignation application Outlook
    Set OL = CreateObject("Outlook.Application")

    '// Pour chaque feuille dans la collection des feuilles
    For Each Feuille In Worksheets

        ' Pour les feuilles autres que Menu, Suivi et Annuaire
        If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then

            With Feuille

                DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
                DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column

                ' plage feuille à envoyer
                Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).Address)

                ' Assignation des objets
                Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor

                ' Création Email et envoi
                With myItem

                    ' Expéditeur, Destinataire, Sujet
                     .SentOnBehalfOfName = "monmail@mail.fr"
                    .To = Feuille.Cells(2, 13).Value
                    .Subject = "Relance " & Feuille.Cells(2, 20).Value
                    .Display

                    Set rng = wDoc.Content

                    ' Corps du mail
                    rng.InsertParagraphBefore
                    rng.Move 4, -1
                    rng.InsertAfter "Bonjour," & vbNewLine
                    rng.InsertAfter vbNewLine & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :" & vbNewLine

                    ' Copie de la plage
                    rng.InsertParagraphAfter
                    rng.Move 4, 1
                    PlageFeuille.Copy
                    rng.Paste
                    rng.Move 4

                    rng.InsertAfter vbNewLine & vbNewLine & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison." & vbNewLine
                    rng.InsertAfter vbNewLine & "Restant à votre disposition pour toute information complémentaire,"

                    ' Police du corps du mail
                    With rng.Font
                        .Name = "Helvetica"
                        .Size = 11
                        .Color = 10050863
                    End With

                    ' Envoi
                    '.Send
                End With

                ' Désassignation des objets
                Set myItem = Nothing: Set wDoc = Nothing
            End With

        End If
    Next Feuille

    '// Désassignation application Outlook
    Set OL = Nothing

End Sub

Franchement, je m'attendais pas à ce que ça fonctionne aussi bien!

J'ai pu changer la couleur à l'aide d'un convertisseur online, remonter la plage dans le mail, et même mettre la taille de la police à 11, ce qui m'était auparavant impossible!

C'est vraiment génial! Première fois que je fais appel aux fofos pour avancer et je ne regrette pas du tout!

Un grand merci à toi thev, j'ai gagné quelques semaines de recherches grâce à toi!

Steelson, je garde ton code de côté, je suis persuadé de pouvoir utiliser tout ça quelque part! Merci pour ton aide!

A bientôt .

Le 18/10/2018 à 15:51

Re .

Finalement, il me reste encore un petit souci...

Après toutes ces modifications, mon .SentOnBehalfOfName ne modifie plus l'adresse d'envoi par défaut :/.

De base j'ai un compte outlook perso et des droits d'envoi sur une boîte générique.

Mon .SentOnBehalfOfName est sensé me permettre d'envoyer à partir de cette BAL générique de la part de ma boîte perso.

Mais là, ça ne modifie plus du tout comme avant, ça reste bloqué sur la boîte perso!

J'ai essayé plusieurs modifications mais rien de concluant...

Vous auriez une solution?

Encore merci :'(

Le 18/10/2018 à 23:08

Bonsoir,

Au lieu de

.SentOnBehalfOfName = "monmail@mail.fr"

Essaie

Dim compte as object
For Each compte In OL.Session.Accounts
   If compte.SmtpAddress = "monmail@mail.fr" Then Set .SendUsingAccount = compte: Exit For
Next compte
Le 19/10/2018 à 08:16

Salut thev!

Je viens de tester ça mais ça ne fonctionne pas .

Si je comprends bien le code que tu m'as envoyé, il sert à changer le compte utilisateur, donc si j'avais deux comptes associées à Outlook ça fonctionnerait.

Je pense que le souci vient du fait que la messagerie générique que j'utilise n'est pas un compte à part entière.

Il s'agit d'un compte associé au mien :

En gros, "maboîteperso" est ma boîte par défaut, celle qui me permet d'utiliser Outlook au travail.

"maboîtegénérique" est une boîte partagée ajoutée via les paramètres de "maboîteperso" (voir la PJ, j'ai du mal à expliquer clairement et ça sera plus parlant ).

Du coup lorsque j'envoie un mail, celui-ci part de "maboîtegénérique" de la part de "maboîteperso", cela permet à mon équipe d'avoir accès directement aux mails envoyés et aux réponses reçues ainsi que d'avoir des archives communes.

Je ne sais pas si je m'exprime clairement, c'est le matin là et je suis dans le brouillard .

Merci quand même pour ton aide .

problemeboites
Le 19/10/2018 à 08:27

Bonjour RyuMatsuda, le forum,

j'suis pas du tout calé en communications, mais juste à tout hasard, essaye sans mettre de guillemets :

Paramètres du Serveur

Serveur : serveurdemonentreprise

Nom d'utilisateur : maboîteperso

de plus, n'écrit pas tel quel le texte bleu ! met les valeurs réelles actuelles !

exemple : Nom d'utilisateur : Ryu Matsuda

(mais si c'est à partir du code VBA, il faut bien les guillemets)

dhany

Le 19/10/2018 à 08:51

Salut dhany! Merci

En fait ce sont des valeurs que je ne peux pas modifier ça!

C'était juste pour essayer d'imager mon explication (le texte en rouge est la censure, confidentialité oblige ).

Le 19/10/2018 à 10:56

Bonjour,

RyuMatsuda a écrit :

i je comprends bien le code que tu m'as envoyé, il sert à changer le compte utilisateur, donc si j'avais deux comptes associées à Outlook ça fonctionnerait.

Oui. Maintenant tu peux regarder le choix exact de comptes émetteur en mettant un arrêt après l'instruction ".Display", au niveau du bouton "De". Le code est en rapport avec ce choix.

Il faudrait essayer

au lieu de

If compte.SmtpAddress = "monmail@mail.fr"

plutôt

If compte.DisplayName = "monmail@mail.fr"

ou

If compte.UserName = "maboîtegénérique"
Le 19/10/2018 à 10:57
RyuMatsuda a écrit :

Finalement, il me reste encore un petit souci...

Après toutes ces modifications, mon .SentOnBehalfOfName ne modifie plus l'adresse d'envoi par défaut :/.

Pour ma culture, est-ce que cela fonctionnait ici : https://forum.excel-pratique.com/viewtopic.php?p=694814#p694814 ?
Le 19/10/2018 à 12:21

Oui Steelson, ça fonctionnait . Un autre de mes outils utilisait justement ce code pour tourner.

Le 19/10/2018 à 14:15
Steelson a écrit :
Steelson a écrit :

Une solution est d'utiliser sendkeys

J'avais préconisé SendKeys, mais j'écris aussi parfois en html dans le VBA

Je dois aussi avoir un module qui crée le html en fonction de la zone (je vais rechercher)

A toutes fins utiles !

Je précise toutefois que :

  • pour les mails j'utilise exclusivement sendkeys (c'est pourquoi je suis très intéressé par la méthode de Thev)
  • mais quand ce n'est pas possible (exemple d'envoi de convocation par fichier joint .ics) alors j'emploie la transformation du texte en html
11mailhtml.xlsm (25.35 Ko)
Le 23/10/2018 à 09:58

Salut tout le monde!

Après plusieurs tentatives, je n'y arrive toujours pas...

Je commence à désespérer! :'(

thev, j'ai essayé tes trois propositions, j'ai même tenté de les modifier en utilisant le négatif au lieu du positif (<>"mailperso" au lieu de ="mailgénérique") mais toujours pas, l'adresse de l'expéditeur reste ma boîte perso!

Merci quand même pour ton aide

Le 03/10/2019 à 13:33

Bonjour à tous,

Sujet non résolu mais je reviens clôturer le sujet.

Je travaille actuellement sur un nouveau projet dans lequel la solution à mon problème devra être trouvé.

Je vais recréer un sujet en partant de cette nouvelle base.

Merci à tous pour votre aide!

Rechercher des sujets similaires à "envoi plage mail"