Copier une plage de cellules dans une image et la coller dans Outlook

**goninph** · 03/11/2024, 00h18

Bonjour,

J'ai une erreur intermittente sur cette ligne : Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

J'ai essayé de faire une pause, à voir dans le temps ...

Si vous avez une solution je suis preneur

Meilleures salutations

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Private Sub BT_Mail_Facturation_Click()
ThisWorkbook.Activate 'Évite que la macro ne se lance sur un autre fichier ouvert
Dim Messagerie As Object
Dim Email As Object
Dim Objet As Variant
Dim Message As Variant
Dim Derniere_Ligne As Long
Dim Tableau As ListObject
Dim Plage As Range
Dim Image As String
Dim Zone_Graphique As ChartObject
Dim f As Worksheet
    Set f = ThisWorkbook.Sheets("Facturation")
 
    If MsgBox("Envoyer un mail au contentieux ? ", vbYesNo + vbQuestion, "Facturation") = vbYes Then
 
        Backup.Ouvrir_Outlook
 
        'Objet du mail
        Objet = "Fichier de facturation mise à jour des sommes reçues - " & f.Range("Cell_Facturation_Cmde") & " - " & f.Range("Cell_Facturation_Adresse")
 
        'Message du mail
        Message = "Bonjour,<br><br>" & _
                  "Avons-nous reçu les paiements ? Voir colonne Etat<br><br>" & _
                  "Meilleures salutations<br>" & _
                  Application.UserName
 
        'Créer une image du tableau
        Set Tableau = f.ListObjects("TS_Facturation")
        If Application.WorksheetFunction.CountA(Tableau.ListColumns("Cmde").DataBodyRange) <> 0 Then
            With Tableau.ListColumns("Cmde").DataBodyRange
                Derniere_Ligne = f.ListObjects("TS_Facturation").Range.Rows(f.ListObjects("TS_Facturation").Range.Rows.Count).Row
            End With
        Else
            Derniere_Ligne = 11
        End If
 
        'Création de l'image
        Application.ScreenUpdating = True 'Forcer à true sinon l'image sera blanche
        Set Plage = f.Range(f.Cells(2, Tableau.ListColumns("Offre").Range.Column), f.Cells(Derniere_Ligne, Tableau.ListColumns("Descriptif").Range.Column))
        Application.Wait Now + TimeValue("00:00:02")
        Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        Image = "C:\temp\Image.jpg"
        Set Zone_Graphique = f.ChartObjects.Add(0, 0, Selection.Width, Selection.Height)
        With Zone_Graphique
            .Activate
            .Height = Plage.Height
            .Width = Plage.Width
            .Chart.Paste
            .Chart.Export Image, "JPG"
            .Delete
        End With
 
        'Création du mail avec Outlook
        Set Messagerie = CreateObject("Outlook.Application")
        Set Email = Messagerie.CreateItem(0)
        With Email
            .To = "contentieux@zurbuchensa.ch"
            .CC = ""
            .Subject = Objet
            .HTMLBody = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & Message & "<br><br></span>" & _
            "<img src='" & Image & "' alt='Image'>"
            .Display
        End With
 
        'Supprimer l'image temporaire
        Kill Image
 
        Messagerie.ActiveWindow.WindowState = 0 '0=Maximized, 1=Minimized, 2=Normal
 
        Set Email = Nothing
        Set Messagerie = Nothing
        Set Tableau = Nothing
        Set Plage = Nothing
        Set Zone_Graphique = Nothing
 
    End If
End Sub

Nom : 2024-11-03_00-11-31.png
Affichages : 236
Taille : 8,4 Ko

**patmeziere** · 05/11/2024, 12h22

Bonjour goninph
1°
il faudra nous expliquer pourquoi tu va chercher l'index de dernière ligne dans un tableaux structuré alors que le data body est sensé te le donner la plage

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set Plage = f.Range(f.Cells(2, Tableau.ListColumns("Offre").Range.Column), f.Cells(Derniere_Ligne, Tableau.ListColumns("Descriptif").Range.Column))

2°
il faudra nous expliquer aussi pourquoi une pause de 2 secondes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
    Application.Wait Now + TimeValue("00:00:02")
 
  Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        Image = "C:\temp\Image.jpg"

3° nous expliquer aussi pourquoi redimensionner dans le bloc with alors qu'il est créé selon la dimension de la plage ;d'ailleurs dans le code a aucun moment tu fait une selection de la dite "Plage" donc selection c'est la plage de cellule sélectionnée actuellement ce qui n'est peut être pas la plage voulue

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Set Zone_Graphique = f.ChartObjects.Add(0, 0, Selection.Width, Selection.Height)
        With Zone_Graphique
            .Activate
            .Height = Plage.Height
            .Width = Plage.Width

4° il faudrait aussi nous expliquer pourquoi là ou il le faudrait (surtout sur les versions d'excel récentes)il n'y a pas de gestion d'attente pour que le paste puisse coller un bitmap dans le chart

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
.Chart.Paste
            .Chart.Export Image, "JPG"
            .Delete
        End With

5°il faudra aussi nous expliquer ce que tu espère dans le code html au niveau du SRC de la balise image
car jusqu’à preuve du contraire la variable image contient le path du fichier dans ton disque dur hors!! le src doit faire référence a une pièce joindre pour être afficher dans le corps du mail autrement dit uniquement le nom avec son extension

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 "<img src='" & Image & "' alt='Image'>"

d'ailleurs a aucun moment dans le code tu envoie l'image dans le serveur utilisé dans ta session outlook ( à moins que mes yeux me jouent des tours )

bref c'est assez brouillon tout ça difficile d'y faire le ménage même si on comprend à peu près l'intention

**goninph** · 14/11/2024, 19h03

La classe merci

Ce code ne réagit pas à la transparence True ou False

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test()
CopyOBJECTInImagePNG ActiveSheet.UsedRange.Resize(, [o1].Column), Environ("userprofile") & "\desktop\monimage.png", False
End Sub

**patmeziere** · 14/11/2024, 19h12

Heu... tu sais lire une fonction toi?
d’après toi pourquoi le dernier est optionnel ?
le code original de ma source
avec exemple d'utilisation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                           COLLECTION IMAGE ET SHAPES
'exporter un object en PNG(range,shapes et tout autre object present sur la feuille)
'version avec graphique 1.3(PNG)
'date version 03/05/2016
'***********************************************************
'Cette version  donne l'avantage de garder la transparence *
'Et semie transparence pour les shapes ou picture          *
'***********************************************************
'mise  à jour:15/07/2018
'suppression de la gestion d'attente par l'api IsClipboardFormatAvailable
'remplacer par un multiple paste dans le chart dans que son pictures.count=0(Idée de @Job75)
'l'area du graph est visible ,solid et transparent  à 100%
'mise  à jour:03/05/2024
'modification du switch transparence
'**********************************************************************************
Option Explicit
Dim cheminT$
 
 
Function CopyOBJECTInImagePNG(ObjectOrRange, _
                              Optional cheminx As String = "", _
                              Optional transparency As Boolean = True) As String
    Dim Graph As Object
    If cheminx = "" Then cheminx = ThisWorkbook.Path & "\imagetemp.png" 'path du fichier par defaut
 
    With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text") 'on vide le clipboard entre chaque copie pour tester vraiment le available
    End With
 
    ObjectOrRange.CopyPicture 'Format:=IIf(Notransparency, xlBitmap, xlPicture)
    Set Graph = ObjectOrRange.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
    Graph.Parent.ShapeRange.Line.Visible = msoFalse
    With Graph.Parent
        .Width = ObjectOrRange.Width: .Height = ObjectOrRange.Height: .Left = ObjectOrRange.Width + 20:
        .Select
        Do: DoEvents: .Chart.Paste: Loop While .Chart.Pictures.Count = 0
 
        With .Chart
            .ChartArea.Fill.Visible = msoTrue
            .ChartArea.Fill.Solid
            If transparency Then
                    .ChartArea.Format.Fill.transparency = 1
                Else
                .ChartArea.Format.Fill.transparency = 0.01
            End If
            .Export cheminx, Split(cheminx, ".")(1)
        End With
    End With
    Graph.Parent.Delete
    CopyOBJECTInImagePNG = cheminx
End Function
 
 
'***************************************************
'sub de test
Sub export_Range_To_ImagePNG()
    Dim Fichier$
    Fichier = ThisWorkbook.Path & "\imagetemp.png"
    CopyOBJECTInImagePNG [Feuil1!A1:F10], Fichier
End Sub
'sub de test
Sub export_Range_To_ImagePNGNOtransparency()
    Dim Fichier$
    Fichier = ThisWorkbook.Path & "\imagetemp.png"
    CopyOBJECTInImagePNG [Feuil1!A1:F10], Fichier, False
End Sub
'***************************************************
 
Sub export_boite_To_ImagePNGNotransparency()
    Dim Fichier$
    Fichier = ThisWorkbook.Path & "\" & ActiveSheet.Shapes("boite").Name & ".png"
    CopyOBJECTInImagePNG ActiveSheet.Shapes("boite"), Fichier
End Sub
Sub export_Object_To_ImagePNGtransparency()
    Dim Fichier$
    Fichier = ThisWorkbook.Path & "\" & ActiveSheet.Shapes("Boule").Name & ".png"
    CopyOBJECTInImagePNG ActiveSheet.Shapes("Boule"), Fichier, True
End Sub

en fait on fait ce qu'on veut range transparente ou pas shapes et picture transparentes ou pas

je considère que ton problème est réglé

**goninph** · 14/11/2024, 19h41

Envoyé par goninph

La classe merci

Ce code ne réagit pas à la transparence True ou False

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test()
CopyOBJECTInImagePNG ActiveSheet.UsedRange.Resize(, [o1].Column), Environ("userprofile") & "\desktop\monimage.png", False
End Sub

En fait c'est normal car l'image présente dans le presse-papier et celle du ObjectOrRange.CopyPicture ...

Encore merci pour tout

**patmeziere** · 14/11/2024, 19h52

re
rien a voir avec le copypicture
l'image est transparente oui
MAIS!!
le fond blanc de l'image finale c'est le fond du chart (transparent ou pas)
c'est pourtant simple à comprendre

**goninph** · 05/11/2024, 17h30

Merci de m'avoir répondu

1. Je définis la plage entre 2 colonnes et que les lignes filtrées

2. C'est justement le problème de ce code qui fonctionne nickel, mais qui plante une fois deux sans la pause et une fois sur dix avec cette pause

3. Sinon l'image est toute petite, aux dimensions d'une cellule

4. L'attente du point 2 devrait être placée ici ?

5. Aucune idée, je sais que l'image est collée à la bonne place dans le mail, mais c'est volontier que je prends une explication ou les corrections nécessaire à apporter

A toute

Le résultat est selon la copie d'écran ci-dessous

Un mail avec une image du tableau collée en dessous

Nom : eee.png
Affichages : 214
Taille : 489,7 Ko

Nom : eee.png
Affichages : 214
Taille : 489,7 Ko

**patmeziere** · 05/11/2024, 18h02

re
que donne simplement l'address du databodyrange de ton tableau structuré filtré dans un msgbox

on pourrait avoir cette feuille avec des données bidons pour tester
mais déjà si tu test le msgbox ça devrait t'éclairer un peu

**patmeziere** · 05/11/2024, 18h17

re
je viens de tester car tu m'a mis le doute

filtré ou pas la capture se fait avec ce qu'il y a de visible
pas besoins de déterminer quoi que ce soit avec un listobject(tableau structuré)
test en filtrant ton tableau

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Sub test()
 'filtré ou pas le tableau sera capturé
 'il n'y aura pas les lignes non visible c'est tout
 Set plage = ActiveSheet.ListObjects("Tableau1").DataBodyRange'adapte le nom de ton TS 
 plage.CopyPicture
ActiveSheet.Paste
 
End Sub

**goninph** · 05/11/2024, 19h25

Le problème principal est la création de l'image qui beug une fois sur cinq sur cette ligne Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Pour la plage je ne veux pas tout le tableau, juste la plage de d'une colonne à une autre des lignes visibles

**patmeziere** · 05/11/2024, 20h21

donne un fichier avec le tableau et on verra ce que l'on peut faire

**goninph** · 05/11/2024, 20h30

Envoyé par patmeziere

donne un fichier avec le tableau et on verra ce que l'on peut faire

Impossible données confidentielles

**patmeziere** · 05/11/2024, 20h32

punaise tu sais pas bidonner quelques cellules
faire un copier et coller valeur pour supprimer toute formule
ca prend 2 sec

bon courage

**goninph** · 05/11/2024, 20h51

Sur mon PC personnel, ce code ne plante plus

À voir demain au job

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Private Sub BT_Mail_Facturation_Click()
ThisWorkbook.Activate ' Évite que la macro ne se lance sur un autre fichier ouvert
Dim Messagerie As Object
Dim Email As Object
Dim Objet As String
Dim Message As String
Dim Derniere_Ligne As Long
Dim Tableau As ListObject
Dim Plage As Range
Dim Image As String
Dim f As Worksheet
 
    Set f = ThisWorkbook.Sheets("Facturation")
 
    If MsgBox("Envoyer un mail au contentieux ? ", vbYesNo + vbQuestion, "Facturation") = vbYes Then
 
        'Ouvrir Outlook si nécessaire
        Backup.Ouvrir_Outlook
 
        'Objet du mail
        Objet = "Fichier de facturation mise à jour des sommes reçues - " & f.Range("Cell_Facturation_Cmde").value & " - " & f.Range("Cell_Facturation_Adresse").value
 
        'Message du mail
        Message = "Bonjour,<br><br>" & _
                  "Avons-nous reçu les paiements ? Voir colonne Etat<br><br>" & _
                  "Meilleures salutations<br>" & _
                  Application.UserName
 
        'Créer une image du tableau
        Application.ScreenUpdating = True ' Forcer à true sinon l'image sera blanche
        Set Tableau = f.ListObjects("TS_Facturation")
        If Application.WorksheetFunction.CountA(Tableau.ListColumns("Cmde").DataBodyRange) <> 0 Then
            Derniere_Ligne = Tableau.Range.Rows(Tableau.ListRows.Count).Row
        Else
            Derniere_Ligne = 11
        End If
 
        'Création de l'image
        Application.ScreenUpdating = True 'Forcer à true sinon l'image sera blanche
        Set Plage = f.Range(f.Cells(2, Tableau.ListColumns("Offre").Range.Column), f.Cells(Derniere_Ligne, Tableau.ListColumns("Descriptif").Range.Column))
        Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
 
        Image = Environ("TEMP") & "\Image.jpg"
        With f.ChartObjects.Add(Left:=Plage.Left, Top:=Plage.Top, Width:=Plage.Width, Height:=Plage.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Image, "JPG"
            .Delete
        End With
 
        ' Création du mail avec Outlook
        Set Messagerie = CreateObject("Outlook.Application")
        Set Email = Messagerie.CreateItem(0)
        With Email
            .To = "contentieux@zurbuchensa.ch"
            .CC = ""
            .Subject = Objet
            .HTMLBody = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & Message & "<br><br></span>" & _
                        "<img src='" & Image & "' alt='Image'>"
            .Display
        End With
 
        ' Supprimer l'image temporaire
        If Dir(Image) <> "" Then Kill Image
 
        Messagerie.ActiveWindow.WindowState = 0 ' 0=Maximized, 1=Minimized, 2=Normal
 
    End If
 
    Set Email = Nothing
    Set Messagerie = Nothing
    Set Tableau = Nothing
    Set Plage = Nothing
End Sub

**Nain porte koi** · 06/11/2024, 09h56

Envoyé par goninph

Sur mon PC personnel, ce code ne plante plus

Ca ne plante pas non plus sur le mien, donc c'est peut-être sur le PC du boulot qu'il y a qqchose qui pose problème, non ? ...surtout si ça n'est pas à chaque fois !

**patmeziere** · 06/11/2024, 10h18

Bonjour bonjour
Nom : demo1.gif
Affichages : 201
Taille : 206,4 Ko

de toute facon quand je vois des trucs du genre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Image = Environ("TEMP") & "\Image.jpg"

et que plus bas je vois

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
.HTMLBody = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & Message & "<br><br></span>" & _
                        "<img src='" & Image & "' alt='Image'>"

alors qu'il n'y a même pas de AddAttachment dans le mail

il va la recevoir la capture le destinataire c'est sur

vous êtes sérieux là ?

gonimph a tu un plan B? je sais pas moi ;des pigeons , un coursier , beep beep

si oui prends le plan B

je prends le temps de t'expliquer

l'image tu la vois par ce que tu es sur ton pc donc le lien est bon
mais quand le mail sera ouvert dans l'application mail de ton destinataire lui n'a pas de lien vers ton pc (et heureusement d'ailleurs)
conclusion il aura un petit carré vide avec une petite crois indiquant que l'image est indisponible

**Nain porte koi** · 08/11/2024, 18h36

Envoyé par Nain porte koi

Ca ne plante pas non plus sur le mien, donc c'est peut-être sur le PC du boulot qu'il y a qqchose qui pose problème, non ? ...surtout si ça n'est pas à chaque fois !

Invité · 08/11/2024, 18h47

Probablement la feuille est protégée et l'insertion de l'objet graphique n'est pas possible

**goninph** · 06/11/2024, 07h39

Bonjour,

Comme demandé le fichier est en pièce jointe

Merci pour votre aide

'!!!!!!!!!!!!!!!!!! Plante un fois sur 2 sur la ligne suivante !!!!!!!!!!!!!!!!!!
Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Image dans mail.xlsm