Insérer un tableau dans le corps d'un e-mail HTML généré par Excel
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 :(
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
@+
Bonsoir Bruno,
C'est vrai la fonction ne prends pas en considérations les images :(
Par contre ton code s'exécute
sans erreur mais je ne reçois pas un e-mail :(.
Je n'ai pas compris pourquoi.
Voici un exemple de ma feuille .
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
@+
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 :)
Bonjour,
Normalement vous avez dû avoir des messages de débogages !?
Voici le fichier avec les corrections
@+
Merci Bruno, je n'ai pas eu une notification de votre réponse.
Merci pour ton aide et bon week end :)
Salut Menal,
Pensez à activer la coche [RESOLU] sur la réponse faite quand c'est le cas
En attendant, c'est fait