Envoi direct par Outlook - Copier/Coller de cellules sélectionnées
Bonsoir à tous,
Je souhaiterais rendre automatique une procédure dans un Dashboard afin de transmettre des informations via Email.
J'ai trouvé deux super codes que je vous livre ci-dessous. Malheureusement je n'arrive pas à les adapter pour mes besoins.
Le premier VBA code ouvre un InputBox afin de déterminer manuellement la zone à copier/coller en Jpeg.
1) Je souhaiterais déterminer par défaut toujours la même zone (ActiveSheet.Range("F3:AL18").Select) sans devoir passer par le InputBox.
2) Je souhaite également vider la mémoire afin de ne pas surcharger le cash
3) Je souhaite également pouvoir envoyer l'Email sans ouverture de fenêtre Outlook
Merci d'ores et déjà de votre soutien.
Cordialemnet
Willau
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>" _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = "ESSAI"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = "Essai@essai.com"
.CC = " "
.Display
End With
End Sub
_________________________________________________________________________________________________________________
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
Bonsoir,
Ca devrait donner ça :
Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Range("F3:AL18") 'en partant du principe que tu es déjà sur la bonne feuille... Sinon il faut l'activer avant,
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>" _
& "<br>Best Regards!</font></span>"
With xOutMail
.Subject = "ESSAI"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = "Essai@essai.com"
.CC = " "
'.Display
End With
Application.CutCopyMode = False
End Sub
_________________________________________________________________________________________________________________
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
Bonjour JoyeuxNoel (la formule est très particulière avec un tel Nick Name
Merci pour ta contribution ! ça m'a énormément aider et l'action principale fonctionne !
J'ai néanmoins un problème par rapport à l'envoi automatique.
Le seul fait d'avoir enlevé ".Display" ne suffit pas à envoyer l'e-mail automatiquement.
J'ai même remplacé ".Display" par ".Send", sans aucun effet.
Je vais essayé de trouver une solution.
Encore Merci !!!
Cordialement
Willau
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
Hello,
Mince, je n'avais même pas fait attention qu'il manquait le .send.
Je pensais que tout était bon à ce niveau comme tu n'en avais pas parlé.
Essaie quand même de restructurer dans cet ordre. Pas dit que ça fonctionne, mais bon ... Ne sait-on jamais.
With xOutMail
.To = "Essai@essai.com"
.Subject = "ESSAI"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Send
End With
J'en ai profité pour virer la ligne .CC = " ", dans laquelle tu envoyais le mail à un espace
Merci JoyeuxNoel !
Je vais tester ça...
Mon Dashboard est en chantier. Le .CC sera utilisé !
Question au sujet de ces options :
Existe-t-il un
.expéditeur
ou quelque chose de la sorte ?
Je souhaite "forcer" l'expéditeur. Dans la boite nous avons notre propre e-mail, mais également des e-mails "techniques".
C'est par cette adresse que je souhaite que les envois se font !
Cordialement
Willau
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
Re,
Ça prend automatiquement le compte par défaut.
J'ai trouvé ce bout de code, à voir s'il st probant ...
Dim C As Account
With xOutMail
For Each C In olApp.Session.Accounts
If C.SmtpAddress = "test1@test1.com" Then
.SendUsingAccount = C
Exit For
End If
Next C
.Display
End With
Re-bonjour JoyeuxNoel
J'ai une étape supplémentaire à franchir.
Je souhaite insérer un texte contenu dans une cellule comme texte dans mon corps d'E-mail.
Plus simplement dit, je souhaite remplacer le "Best Regards!" par Range("M104").
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>" _
& "<br>Best Regards!</font></span>"
J'ai essayé différentes voix, sans succès.
Aurais-tu une idée pour résoudre ce problème?
D'avance merci.
Cordialement
Willau
- Messages
- 3'581
- Excel
- 2013, 2019, 365
- Inscrit
- 11/04/2020
- Emploi
- Formateur bureautique, dvpt fichiers
Re,
je ferais ça :
& "<br>" & Range("M104") & "</font></span>"