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

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

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

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

Re,

je ferais ça :

& "<br>" & Range("M104") & "</font></span>"