Macro - envoyer cellules par mail - coller automatiquement format image

Bonjour à toutes et tous,

Oui c'est encore moi, mais pour une demande plus complexe (enfin pour moi)

Dans un fichier Excel au travail j'ai une macro qui, quand on clique sur un bouton fait deux choses,

1. elle ouvre une fenêtre « nouveau message » sur Outlook préremplis avec les adresses mail des correspondants et l'objet.
2. Elle selectionne et copie, sur le fichier Excel, les cellules à récupérer.

Il suffit par la suite de faire un clic droit --> Coller en tant qu'image dans les corps du message sur Outlook.

Y aurait-il un moyen de faire en sorte que ça colle automatiquement sous forme d'image ?

Je peux copier sous forme d'image, je viens d'y penser à l'instant, avec cette procédure :

.CopyPicture Appearance:=xlScreen, Format:=xlPicture

J'ai essayé avec .Body.Paste pour coller automatiquement, mais ça ne fonctionne pas, j'imagine que l'on ne fait pas comme ça.

Je bloque, j'ai cherché sur Internet et trouve du code VBA très long, n'y a t-il, pas un moyen d'ajouter simplement une procédure à mon code VBA ?

Je me demande aussi si dans l'instruction

Range("A1:N20").Select
Selection.Copy

les procédures .Select et Selection.Copy ne font pas un peu doublon pour pas grand-chose et qu'écrire simplement

Range("A1:N20").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Ne serait pas plus rapide.

Code VBA - - - - - - - - - -

Public Sub CopierCellulesPourMail_Click()
    Dim oOutlook As Object
    Set oOutlook = CreateObject("Outlook.Application")
    Dim oMail As Object
    Set oMail = oOutlook.CreateItem(0)

    With oMail
        To = "test@monmail.com"
        If Time > "07:00" And Time < "16:00" Then
        Range("A1:N20").Select
        Selection.Copy
        .Subject = "objet du mail 1"
        End If

        If Time > "16:00" And Time < "21:00" Then
        Range("A1:R20").Select
        Selection.Copy
        .Subject = "Objet du mail 2"
        End If
    .Display
    End With
End Sub

Merci pour votre aide

Tiens tu dois pouvoir réaliser ce que tu veux faire avec ce code.

Sub EnvoyerEmailAvecImage()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim ws As Worksheet
    Dim Plage As Range
    Dim ImageObj As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim ImagePath As String

    ' Définir la feuille et la plage à copier
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Modifier selon le nom de la feuille
    Set Plage = ws.Range("A1:D10") ' Modifier selon la plage à capturer

    ' Copier la plage en tant qu'image
    Plage.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    ' Créer un objet temporaire pour stocker l'image
    Set ImageObj = ws.ChartObjects.Add(0, 0, Plage.Width, Plage.Height)
    With ImageObj
        .Chart.Paste
        .Chart.Export Filename:=Environ("TEMP") & "\ImageEmail.png", FilterName:="PNG"
        ImagePath = Environ("TEMP") & "\ImageEmail.png"
        .Delete
    End With

    ' Ouvrir Outlook et créer un nouveau mail
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    ' Construire l'e-mail
    With OutlookMail
        .To = "destinataire@example.com"
        .CC = ""
        .BCC = ""
        .Subject = "Objet de l'email"
        .BodyFormat = 2 ' Format HTML
        .HTMLBody = "<p>Bonjour,</p><p>Veuillez trouver ci-dessous l'image :</p>" & _
                    "<img src='cid:Image1'>" & _
                    "<p>Cordialement.</p>" & .HTMLBody

        ' Ajouter l'image en pièce jointe et la référencer dans le HTMLBody
        .Attachments.Add ImagePath, 1, 0, "Image1"

        ' Afficher l'e-mail avant envoi
        .Display
    End With

    ' Nettoyage des objets
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Bonsoir,
fgfrx bonsoir,

vous trouverez une conversation ici où je propose suite à un mélange trouvé sur internet la possibilité de copier/coller une plage de cellules dans le corps du message tout en les laissant exploitables, ce n'est pas une image.

Il est bien évident qu'il y a des modifications à faire pour votre demande, c'est juste pour vous montrer "la différence".

@ bientôt

LouReeD

Bonjour vgfrx, LouReeD et tout le monde,

Désolé du retard de ma réponse, mais c'est un code VBA pour mon travail et en ce moment je n'ai pas vraiment le temps. Chez moi j'utilise LibreOffice Calc sous Linux donc je n'ai pas Excel pour me mettre dessus le soir.

Alors, voici on j'en suis, déjà merci pour les retours bien utiles, je m'en suis inspirés ainsi que de tout un tas de code trouvés par-ci par là et voici où j'en suis arrivé, c'est presque parfait.

En utilisant les objets Word (WordDoc, WordRange) cela fonctionne, c'est-à-dire que l'image se colle bien automatiquement dans le mail, mais le souci est sa taille qui est petite et il faut donc l'agrandir à la main (en tirant sur les poignées de redimensionnement).

J'ai trouvé les propriétés objet.Height objet.Width mais ça ne semble pas fonctionner dans mon cas, ou je ne sais pas m'en servir ce qui est plus probable.

Y a-t-il un moyen de lui donner une taille via le code VBA ? Afin quelle soit bien proportionnée dans le corps du mail ?

Code VBA (désolé pour l'indentation probablement mauvaise) - - - - - - - - - -

Public Sub EnvoyerRapportParMail_Click()

    ' Déclaration des variables.
        Dim OutlookApp As Object
        Dim OutlookMail As Object
        Dim ws As Worksheet
        Dim WordDoc As Object
        Dim WordRange As Object
        Dim PlageACopierAs Range

    ' Référencer la feuille active.
        Set ws = ActiveSheet

    ' Définir la plage à copier.
        Set PlageACopier = ws.Range("B3:P30")

    ' Créer une instance d'Outlook.
        Set OutlookApp = CreateObject("Outlook.Application")

    ' Vérifier la présence d'un explorateur Outlook.
        If OutlookApp.Explorers.Count = 0 Then
        OutlookApp.Session.GetDefaultFolder(olFolderInbox).Display
        OutlookApp.ActiveExplorer.WindowState = olMinimized
        End If

    ' Créer un nouveau mail.
        Set OutlookMail = OutlookApp.CreateItem(0)

    ' Remplissage du mail.
        With OutlookMail

    'Sujet, destinataire, signature.
        .Subject = "Rapport numéro 1 du " & Date & " avec image"
        .To = mail1@test.fr;mail2@test.fr
        .Display 'affichage pour insertion signature.

    'Corps du mail.
        Set WordDoc = .GetInspector.WordEditor
        Set WordRange = WordDoc.Range(0, 0)
        With WordRange
        .Text = "Bonjour," & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Voici le rapport numéro 1 du " & Date & " avec  image:" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
        .Move 4, 1

    ' Coller les cellules dans le corps du mail sous forme d’image.
        PlageACopier.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Paste
        .Move 4, 2
        End With

    ' Afficher le brouillon du mail pour que l'utilisateur puisse le vérifier avant envoi
        .Display
        End With

    ' Libérer les objets Outlook et Word
        Set WordRange = Nothing
        Set WordDoc = Nothing
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing

End Sub

Merci encore pour l’aide apportée

Bonsoir,

voir le fichier joint avec le module RangeToHTML comme proposé sur mon précédent message :

Sinon avec votre code, vu que l'image est copier xlScreen, peut être qu'en faisant un zoom positif de la feuille avant copie vous obtiendrez la taille voulue lors du copier coller.

@ bientôt

LouReeD

Rebonjour,

J’ai enfin réussi, j’ai persévéré dans ma logique de vouloir coller sous forme d’image dans le corps du mail, car c'est ce que l'on me demande plus ou moins au boulot bien que votre solution fonctionnait et merci beaucoup pour le fichier

Voici ce que j’arrive maintenant à faire :

1 - l’utilisateur clique sur un bouton.

2 - le bon tableau est sélectionné, copié et collé dans la feuille courante sous forme d’image, puis celle-ci est coupée.

3 - Un nouveau mail est créé.

4 - L'image précédemment coupée est automatiquement collée dans le corps du mail en étant redimensionnée afin d'être à la bonne taille.

Il y a également un objet de mail personnalisé et du texte avant le tableau. A mon boulot j’ai même ma signature pro qui s’ajoute automatiquement, donc c’est tout bon.

Je poste le code VBA final si ça peut aider d’autres personnes :

Sub EnvoyerMenuParMail_Click()

'Déclarer les variables.
     Dim OutApp As Object
     Dim OutMail As Object
     Dim table As Range
     Dim pic As Picture
     Dim ws As Worksheet
     Dim wordDoc

'Créer une instance d'Outlook.
    Set OutlookApp = CreateObject("Outlook.Application")
    'Vérifier la présence d'un explorateur Outlook
        If OutlookApp.Explorers.Count = 0 Then
            OutlookApp.Session.GetDefaultFolder(olFolderInbox).Display
            OutlookApp.ActiveExplorer.WindowState = olMinimized
        End If

'Créer un nouveau mail.
    Set OutlookMail = OutlookApp.CreateItem(0)
    'Sélectionner le tableau convertir en image et couper.
     Set ws = ThisWorkbook.ActiveSheet
    Set table = ws.Range("C3:H23")
    ws.Activate
    table.Copy
    Set pic = ws.Pictures.Paste
    pic.Cut

'Créer un nouveau message, coller l'image dedans, la redimensionner et inscrire du texte avant celle-ci.
On Error Resume Next
    With OutlookMail
    .to = bob@leponge.com
    .Subject = "Menu de la Langouste Croustillante"
    .Display
    Set wordDoc = .GetInspector.WordEditor
    Set WordRange = wordDoc.Range(0, 0)
        With WordRange
        .Text = "Hello Bob, voici le menu de la Langouste Croustillante"
        .Move 4, 1
        .PasteandFormat wdChartPicture
            With wordDoc.InlineShapes(1)
            .ScaleHeight = 100
            End With
        End With
    End With

On Error GoTo 0

Set OutApp = Nothing
Set OutMail = Nothing

End Sub

Merci à tout le monde pour l'aide

Bonsoir,

bravo pour votre persévérance ! Merci également pour votre retour et remerciement !

@ bientôt

LouReeD