Création de mail automatique

Bonjour,

je souhaiterai créer un mail automatisé depuis mon fichier excel les niveaux des marchés, j'utilise le code suivant:

Sub mail()

Dim smail As Worksheet
Set smail = ActiveWorkbook.Sheets("Mail auto")

Dim r As Range
Set r = smail.Range("I1:X36")
r.CopyPicture xlScreen, xlBitmap

 On Error Resume Next
        Set OutApp = GetObject(, "Outlook.Application")
        If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
        On Error GoTo 0

         Set outMail = OutApp.CreateItem(0)
        With outMail
            .BodyFormat = olFormatHTML
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = ""

            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.collapse 1
            oRng.Paste
            .Display
           ' .send
        End With

End Sub

Cela fonctionne bien, hormis le fait que lorsque le mail est affiché, le rendu est beaucoup trop petit:

auriez vous un moyen de pouvoir agrandir le rendu?

Sur mon fichier excel c'est déja assez imposant, je ne vois pas encore agrandir mes tableaux:

Merci par avance pour votre aide,

Bonne journée

Bonjour Assurances T

Pour moi, si vous voulez un format optimal, il faut coller une image et non les cellules

Vous avez un exemple ici
https://www.excel-pratique.com/fr/telechargements/utilitaires/pdf-email-vba-excel-no508

A+

Bonjour Bruno, Top merci cela marche parfaitement, et bravo pour ton fichier excel il est tres instructif !

J'avais par ailleurs une petite remarque, sais-tu si en modifiant ta macro on peut enlever le "cadre noir" qu'il y a autour de l'image:

passé de ça:

à ça:

je sais que l'on va me faire la remarque si je présente la première solution, donc autant essayer de devancer et voir si c'est possible, je pense que ça doit être en rapport avec le format de l'image...

Belle après-midi,

Re et merci

Dans la fonction CopyRangeToJPG, on peut ajouter le fait de mettre la bordure en blanc (pas trouvé autre chose)

En ajoutant cette ligne

.Border.Color = vbWhite

Ou alors celle-ci

ActiveSheet.Shapes(ActiveChart.Parent.Name).Line.Visible = msoFalse

Voici le code entier

Private Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
  Dim PictureRange As Range
  ' Avec ce classeur
  With ActiveWorkbook
    On Error Resume Next
    '.Worksheets(NameWorksheet).Activate
    Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
    If PictureRange Is Nothing Then
      MsgBox "Désolé, mais la plage n'est pas correcte"
      On Error GoTo 0
      Exit Function
    End If
    ' Copier la plage
    PictureRange.CopyPicture
    ' Mémoriser les dimensions
    ImgW = PictureRange.Width
    ImgH = PictureRange.Height
    ' Créer un graphique vide et y coller l'image
    With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, _
      PictureRange.Top, PictureRange.Width, PictureRange.Height)
      .Activate
      .Border.Color = vbWhite
      ' Ou
      ' ActiveSheet.Shapes(ActiveChart.Parent.Name).Line.Visible = msoFalse
      .Chart.Paste
      .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
    End With
    .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
  End With
  CopyRangeToJPG = Environ$("temp") & "\NamePicture.jpg"
  Set PictureRange = Nothing
End Function

Rebonjour Bruno,

Excuse moi pour ma réponse tardive, je n'avais pas vu le mail de notfication, et bah c'est nickel ça fonctionne de manière impécable, un grand merci à toi.

Te souhaitant une bonne après-midi et bon long week end