Insérer un tableau dans le corps d'un e-mail HTML généré par Excel

Le 30/01/2021 à 21:57

Bonjour Famille,

J'ai un petit souci avec mon code, j'ai cherché bcoup mais j'ai pas trouve une solution :'(
En gros, j'ai une feuille, ou je veux s'il y'a une modification un e-mail serait envoyer. J'ai écrit le code et tous marche. Sauf que je voulais dans le corps de mon e-mail recevoir les données de la ligne où la modification a été faite. Pour vous donner une idée, voici mon code:

Option Explicit
Dim ValCell As Variant
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Destinataire As String, xOutApp As Object, OutMail As Object, xMailItem As String
Dim xMailBody As String, SigString As String, Signature As String, DernLigne As Long, nomfeuille As String, ThisRow As Long
Dim i As Integer, Cpt As Integer, CptSh As Integer, dercol As Long
On Error Resume Next
If Target.Column = 10 And Target.Value = "Gagnée" Then

Application.EnableEvents = False
If MsgBox("Êtes-vous certain de rendre l'offre gagnée? ", vbYesNo + vbExclamation + vbDefaultButton2, "Modification d'état de vente") = vbNo Then
Target.Value = ValCell
Else
Cpt = 0
CptSh = Sheets.Count
For i = 1 To CptSh
If Sheets(i).Name <> "Clients Gagnés 2021" Then Cpt = Cpt + 1 Else Exit For
Next i
If Cpt = CptSh Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Clients Gagnés 2021"
Sheets("Affaires 2021").Rows(1).EntireRow.Copy
Sheets("Clients Gagnés 2021").Select
Sheets("Clients Gagnés 2021").Cells(1, 1).EntireRow.Select
ActiveSheet.Paste
Application.CutCopyMode = False

dercol = Sheets("Clients Gagnés 2021").Range("IV1").End(xlToLeft).Column + 1
Sheets("Clients Gagnés 2021").Cells(1, dercol).Value = "N°Installation"
Sheets("Clients Gagnés 2021").Range("A1").Select
ActiveWindow.SmallScroll ToRight:=23
Selection.Copy
Sheets("Clients Gagnés 2021").Cells(1, dercol).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
DernLigne = Sheets("Clients Gagnés 2021").Range("a65536").End(xlUp).Row + 1
ThisRow = Target.Row
Sheets("Affaires 2021").Rows(ThisRow).EntireRow.Copy
Sheets("Clients Gagnés 2021").Select
Sheets("Clients Gagnés 2021").Cells(DernLigne, 1).EntireRow.Select
ActiveSheet.Paste
Application.CutCopyMode = False

Set xOutApp = CreateObject("Outlook.Application")
Set OutMail = xOutApp.CreateItem(0)
Destinataire = "xx.x@xx.com"
xMailItem = "Une nouvelle offre a été rapportée"
xMailBody = ""
SigString = Environ("appdata") & _
"\Microsoft\Signatures\x.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = Destinataire
.Subject = xMailItem
.HTMLBody = xMailBody & "<br>" & Signature
.Attachments.Add (ThisWorkbook.FullName)
.Display
End With
Sheets("Clients Gagnés 2021").Select
nomfeuille = ActiveSheet.Name
MsgBox ("Un e-mail a été envoyé à " & Destinataire & " et le nouveau client gagné a été ajouté à la feuille " & nomfeuille)
End If
Application.EnableEvents = True
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Clients Gagnés 2021").Range("A" & DernLigne).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 10 And Target.Count = 1 Then
ValCell = Target
End If
End Sub

J'ai besoin de votre aide vraiment, je suis débutante :(

Le 31/01/2021 à 20:41

Bonjour Menal,

01) Il faut oublier ce code (d'un autre âge) et qui ne fonctionne pas quand vous avez un logo dans votre signature

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Pour l'avoir, il suffit d'afficher le mail avant de le remplir

02) voici un code optimisé à tester, car sans fichier ce n'est pas simple

Option Explicit
Dim ValCell As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Destinataire As String, OutObj As Object, eMail As Object
  Dim DernLigne As Long, ThisRow As Long
  Dim ShtA As Worksheet, ShtCG As Worksheet
  Dim Cpt As Integer, CptSh As Integer, dercol As Long
  On Error Resume Next
  If Target.Column = 4 And Target.Value = "Gagnée" Then
    Application.EnableEvents = False
    If MsgBox("Êtes-vous certain de rendre l'offre gagnée? ", vbYesNo + vbExclamation + vbDefaultButton2, "Modification d'état de vente") = vbNo Then
      Target.Value = ValCell
      Exit Sub
    End If
    ' Définir la feuille des affaires
    Set ShtA = Sheets("Affaires 2021")
    ' Vérifier l'existence de la feuille Clients Gagnés
    On Error Resume Next
    Set ShtCG = Sheets("Clients Gagnés 2021")
    If Err.Number <> 0 Then
      Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Clients Gagnés 2021"
      ' définir la feuille Clients Gagnés
      Set ShtCG = Sheets("Clients Gagnés 2021")
      ' Copier les valeurs
      ShtA.Rows(1).EntireRow.Copy Destination:=ShtCG.Range("A1")
      With ShtCG
        dercol = .Range("IV1").End(xlToLeft).Column + 1
        .Cells(1, dercol).Value = "N°Installation"
        .Range("A1").Copy
        .Cells(1, dercol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
          SkipBlanks:=False, Transpose:=False
      End With
    End If
    ' Gestion normales des erreurs
    On Error GoTo 0
    '
    DernLigne = ShtCG.Range("A" & Rows.Count).End(xlUp).Row + 1
    ThisRow = Target.Row
    ' Copier les 5 colonne et les coller
    ShtA.Range("A" & ThisRow).Resize(1, 5).Copy Destination:=ShtCG.Cells(DernLigne, 1)
    ' Création d'une instance Outlook pour envoyer un mail
    Set OutObj = CreateObject("Outlook.Application")
    Set eMail = OutObj.CreateItem(0)
    ' Avec mon objet Email
    With eMail
      .Display  ' Afficher le mail pour afficher la signature
      ' Destinataire(s) du mail
      .To = "emaildestinataire@fai.fr"
      ' Copie du mail
      .CC = "emaildestinataire@fai.fr"
      ' Sujet de l'eMail
      .Subject = "Une nouvelle offre a été rapportée"
      ' Corps du mail avec signature à la fin
      .HtmlBody = "Bonjour," & "<BR><BR>" _
        & RangetoHTML(ShtCG.Range("A1:F" & DernLigne)) & .HtmlBody
      ' Joindre le fichier précédemment créé
      '.Attachments.Add sPath & sFileName
      ' Envoyer l'email
      '.Send
    End With
    ' Effacer les variable objet
    Set eMail = Nothing: Set OutObj = Nothing
    MsgBox ("Un e-mail a été envoyé à " & Destinataire & " et le nouveau client gagné a été ajouté à la feuille " & ShtCG.Name)
    Application.EnableEvents = True
  End If
  '
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  '
  ShtCG.Range("A" & DernLigne).RemoveDuplicates Columns:=1, Header:=xlNo
  ' Effacer les variables objet
  Set ShtA = Nothing: Set ShtCG = Nothing
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = 10 And Target.Count = 1 Then
    ValCell = Target
  End If
End Sub

Function RangetoHTML(rng As Range)
  ' Changed by Ron de Bruin 28-Oct-2006
  ' Working in Office 2000-2016
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook

  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  'Copy the range and create a new workbook to past the data in
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With

  'Publish the sheet to a htm file
  With TempWB.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With

  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.readall
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")

  'Close TempWB
  TempWB.Close savechanges:=False

  'Delete the htm file we used in this function
  Kill TempFile

  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
End Function

@+

Le 31/01/2021 à 21:45

Bonsoir Bruno,

C'est vrai la fonction ne prends pas en considérations les images :(

Par contre ton code s'exécute

14test.xlsm (25.77 Ko)

sans erreur mais je ne reçois pas un e-mail :(.

Je n'ai pas compris pourquoi.

Voici un exemple de ma feuille .

Le 31/01/2021 à 22:25

Re,

Attention je n'ai pas fais de ".send" dans le code, c'est un envoi manuel 

   With OutMail
      .Diplay ' Afficher le mail vide mais avec la singature
      .To = Destinataire
      .Subject = xMailItem
      .HTMLBody = xMailBody & "<br>" & RangetoHTML(ShtA.Range("A" & Target.Row & "Z" & Target.Row)) & .HTMLBody
      '.Attachments.Add (ThisWorkbook.FullName)
    ' Envoyer le mail
     .Send
    End With

@+

Le 01/02/2021 à 08:31

Bonjour,

Oui, même l'e-mail ne s'affiche pas.

J'ai mi la feuille, tu peux vérifier :(

J'ai pas compris ma faute.

De plus pour la signature, tu as dit que je l'ajoute manuellement et non pas par une fonction?

Une petite autre question, est ce que c'est possible d'ajouter à l'e-mail une pièce jointe présente dans le PC ?

Bon début de la semaine :)

Le 01/02/2021 à 19:58

Bonjour,

Normalement vous avez dû avoir des messages de débogages !?

Voici le fichier avec les corrections

28menal-test-v2.xlsm (28.49 Ko)

@+

Le 05/02/2021 à 12:15

Merci Bruno, je n'ai pas eu une notification de votre réponse.

Merci pour ton aide et bon week end :)

Le 05/02/2021 à 15:02

Salut Menal,

Pensez à activer la coche [RESOLU] sur la réponse faite quand c'est le cas

En attendant, c'est fait

Rechercher des sujets similaires à "inserer tableau corps mail html genere"