Discussion :

[goninph]

Alors là, je n'ai pas de mot pour remercier patmeziere

Un grand merci pour le temps passé à créer cette vidéo et pour toutes ces explications

Je vais tester demain au boulot

Merci merci merci

Allez je prends le temps
regarde bien la video

et pour finir si je dois mettre au propre l'intention

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
Option Explicit
Sub Mail_Facturation()
    ThisWorkbook.Activate ' Évite que la macro ne se lance sur un autre fichier ouvert
    Dim Messagerie As Object, Email As Object, Objet$, Message$, Plage As Range, Image$, f As Worksheet
 
    Set f = ThisWorkbook.Sheets("Facturation")
 
    If MsgBox("Envoyer un mail au contentieux ? ", vbYesNo + vbQuestion, "Facturation") = vbYes Then
 
        Image = Environ("TEMP") & "\Image.jpg"
        '-------------------------------------------------------------------------------------
        'Message du mail
        Message = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & _
                   "Bonjour,<br><br>" & _
                   "Avons-nous reçu les paiements ? Voir colonne Etat<br><br>" & _
                   "Meilleures salutations<br>" & _
                   Application.UserName & "<br><br></span>" & _
                   "<img src='" & Mid(Image, InStrRev(Image, "\") + 1) & "' alt='Image'>"
        '-------------------------------------------------------------------------------------
 
        Application.ScreenUpdating = True ' Forcer à true sinon l'image sera blanche
        '-------------------------------------------------------------------------------------
 
        'le tableau a copier
        Set Plage = Range("TS_Facturation[[#headers],[#data],[Année]:[Descriptif]]")
 
        If WorksheetFunction.CountA(Plage.Columns(1)) > 2 Then
            Set Plage = Plage.Resize(Plage.Rows.Count + Plage.Row - 2).Offset(-Plage.Row + 2)
        Else 'si il n'y a pas de dats dans le TS
            Set Plage = f.[a2].Resize(Plage.Row - 2, Plage.Columns.Count)
        End If
        '-------------------------------------------------------------------------------------
 
        Plage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        '-------------------------------------------------------------------------------------
        'Object chart pour export de la capture
        With f.ChartObjects.Add(Left:=Plage.Left, Top:=Plage.Top, Width:=Plage.Width, Height:=Plage.Height)
            .Activate
            Do While .Chart.Pictures.Count = 0: .Chart.Paste: Loop
            .Chart.Export Image, "JPG"
            .Delete
        End With
        '-------------------------------------------------------------------------------------
 
        'Object Mail Outlook
        'Objet du mail
        Objet = "Fichier de facturation mise à jour des sommes reçues - " & CStr(f.Range("Cell_Facturation_Cmde").Text) & " - " & CStr(f.Range("Cell_Facturation_Adresse").Text)
        ' Création session Outlook
        Set Messagerie = CreateObject("Outlook.Application")
        Set Email = Messagerie.CreateItem(0)
        With Email
            .To = "contentieux@zurbuchensa.ch"
            .CC = ""
            .Subject = Objet
            .Attachments.Add Image ' une premiere fois pour qu'il soit dipo sur le serveur du mail
            .Attachments.Add Image ' une 2d fois si on veux qu'elle soit en piece jointe aussi
            .HTMLBody = Message
            .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 Plage = Nothing
End Sub

voila là ton mail va partir avec l'image

[laurent_ott]

Bonjour,
J'utilise une autre approche pour incorporer "l'mage" d'une plage ou d'un tableau Excel dans le corps du message d'un courriel Outlook.
C'est expliqué dans cette documentation : Fonctions en VBA pour générer des courriels depuis Excel (au chapitre III.E, mais est recommandé de lire les chapitres précédents pour mieux comprendre comment ça marche.)

Pour résumer le principe : on utilise la méthode ActiveWorkbook.PublishObjects.Add pour générer un fichier au format HTML, puis on l'insert dans le corps de message.
Çà répondra peut-être à votre besoin.

La documentation explique aussi comment insérer une "vraie" image ou un graphique, au cas où.

Bonne continuation.

[patmeziere]

une autre astuce aussi
c'est d'utiliser une feuille pour préparer la présentation du mail
formater le texte comme on le souhaite
et récupérer le contenu en html avec ma toute petite fonction de rien du tout

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
Function htmltexte(cel As Range)
'Fonction de récupération du code html du texte formaté dans la cellule
'Patricktoulon (2016)
    Dim cde$, elem, Dc As Object
   Set Dc = CreateObject("htmlfile")
   cde = Replace(Replace(Replace(cel.Value(11), "ss:", ""), "Data", "Div"), "html:", "")
    cde = Replace(cde, "
", "<br>")
    With Dc
        .body.innerhtml = cde
        For Each elem In .all
            If elem.getattribute("size") <> "" Then elem.Style.FontSize = elem.getattribute("size") & "pt"
            elem.removeattribute ("size")
        Next
        htmltexte = .getelementsbytagname("div")(0).innerhtml
    End With
End Function
 
Sub test()
MsgBox htmltexte([A1])
End Sub

[goninph]

Le code plante toujours une fois sur cinq
Plage.CopyPicture Apparence:=xlScreen, Format:=xlBitmap

[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 !

[rMist2024]

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

[goninph]

Aucune protection sur la feuille

[patmeziere]

Bonsoir goninph
j'ai testé ma solution sur 2007 2013 2016 et 2021
et je n'ai eu aucun problème
2 solutions
soit ton fichier est corrompu dans le Core.xml voir dans les xml des feuilles
soit tu a un sérieux problème de librairie

veux tu bien tester celui ci comme ça on sera fixé

[jurassic pork]

Hello,
tu peux essayer d'effacer le presse-papier avant de l'utiliser :

Code :

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

 Application.CutCopyMode = False

Sinon tu peux essayer d'utiliser ma dll-interface-vba-dotnet qui entre autres permet de gérer les images dans le presse-papier.
Ce n'est pas très compliqué à utiliser :
Après avoir récupérer les DLL ( 1 pour Excel 32 bits et 1 pour Excel 64 bits) il faut les déclarer dans le module :

Code :

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

1
2
3
4
5
#If Win64 Then
    Declare PtrSafe Function CreatePressePapierClass Lib "D:\Tmp\ClassesCSharpJP\ClassesCSharpJPx64.dll" () As Object
#Else
    Declare PtrSafe Function CreatePressePapierClass Lib "D:\Tmp\ClassesCSharpJP\ClassesCSharpJPx86.dll" () As Object
#End If

et voici l'utilisation pour ton programme de courriel :

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
Sub Mail_Facturation()
    ThisWorkbook.Activate ' Évite que la macro ne se lance sur un autre fichier ouvert
    Dim Messagerie As Object, Email As Object, Objet$, Message$, Plage As Range, Image$, f As Worksheet
    Dim pp As Object
    Set pp = CreatePressePapierClass()
    Set f = ThisWorkbook.Sheets("Facturation")
    If MsgBox("Envoyer un mail au contentieux ? ", vbYesNo + vbQuestion, "Facturation") = vbYes Then


        Image = Environ("TEMP") & "\Image.png"
        '-------------------------------------------------------------------------------------
        'Message du mail
        Message = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & _
                   "Bonjour,<br><br>" & _
                   "Avons-nous reçu les paiements ? Voir colonne Etat<br><br>" & _
                   "Meilleures salutations<br>" & _
                   Application.UserName & "<br><br></span>" & _
                   "<img src='" & Mid(Image, InStrRev(Image, "\") + 1) & "' alt='Image'>"
        '-------------------------------------------------------------------------------------


        Application.ScreenUpdating = True ' Forcer à true sinon l'image sera blanche
        '-------------------------------------------------------------------------------------


        'le tableau a copier
        Set Plage = Range("TS_Facturation[[#headers],[#data],[Année]:[Descriptif]]")


        If WorksheetFunction.CountA(Plage.Columns(1)) > 2 Then
            Set Plage = Plage.Resize(Plage.Rows.Count + Plage.Row - 2).Offset(-Plage.Row + 2)
        Else 'si il n'y a pas de dats dans le TS
            Set Plage = f.[a2].Resize(Plage.Row - 2, Plage.Columns.Count)
        End If
        pp.Clear ' On efface le Presse-papier
        Plage.Copy
        Debug.Print "Image présente dans Presse-papier : " & pp.ContainsImage
        pp.SaveImage Image, 0 'on sauvegarde l'image du pressepapier dans le fichier temporaire


 ------------------------------------------------------------------------


        'Object Mail Outlook
        'Objet du mail
        Objet = "Fichier de facturation mise à jour des sommes reçues - " & CStr(f.Range("Cell_Facturation_Cmde").Text) & " - " & CStr(f.Range("Cell_Facturation_Adresse").Text)
        ' Création session Outlook
        Set Messagerie = CreateObject("Outlook.Application")
        Set Email = Messagerie.CreateItem(0)
        With Email
            .To = "contentieux@zurbuchensa.ch"
            .CC = ""
            .Subject = Objet
            .Attachments.Add Image ' une premiere fois pour qu'il soit dipo sur le serveur du mail
            .Attachments.Add Image ' une 2d fois si on veux qu'elle soit en piece jointe aussi
            .HTMLBody = Message
            .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 Plage = Nothing
    Set pp = Nothing
End Sub

On utilise ici un Copy et pas un CopyPicture et l'image est sauvegardée en PNG ce qui meilleur que du jpg pour une image qui comporte beaucoup de morceaux de même couleur (comme une plage de feuille Excel sans objets graphiques) . Dans ce cas cela compresse beaucoup sans dégradation. Le Jpg c'est plutôt pour des photos avec beaucoup de détails.

Ami calmant, J.P

[patmeziere]

Bonjour jurassic pork
à utiliser une dll externe autant le faire avec olecreatepictureindirecte
ci joint un des modules de mon complement utilitaire

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
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'capturer une plage en bitmap et créer une image en memoire (Ipicture)pour
's'en servir dans un control image dans un userform
'patricktoulon sur developpez.com
'utilisation d'un  clisd pour la structure IPictureIID
'date/22/03/2010
'remasteurisation du code date: 12/09/2023
'api creation object image
'abandon du vb6
Option Explicit
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongPtr
Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
 
Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Type PICTDESC: cbSize As Long: picType As Long: himage As LongPtr: hPal As LongPtr: End Type
 
 
 
Function copyxlPicture(obj, Optional lPath As String = "") As IPicture
    Dim hCopy As LongPtr, PictStructure As PICTDESC, DispatchInfo As GUID, IPic As IPicture, T#
    obj.CopyPicture
    OpenClipboard 0
    T = Timer
    Do While hCopy = 0
        hCopy = CopyEnhMetaFileA(GetClipboardData(14), vbNullString)
        If Timer - T > 1 Then Exit Do
    Loop
    CloseClipboard
    If hCopy = 0 Then Set copyxlPicture = IPic: Exit Function ' si pas de handleimage WMF dans clip on arrete tout
    With DispatchInfo
        .Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A: .Data4(0) = &H8B: .Data4(1) = &HBB
        .Data4(2) = &H0: .Data4(3) = &HAA: .Data4(4) = &H0: .Data4(5) = &H30: .Data4(6) = &HC: .Data4(7) = &HAB
    End With
    With PictStructure: .cbSize = Len(PictStructure): .picType = 4: .himage = hCopy: .hPal = 0: End With
    OleCreatePictureIndirect PictStructure, DispatchInfo, True, IPic
    Set copyxlPicture = IPic
    If lPath <> "" Then SavePicture IPic, lPath: Set IPic = Nothing
    OpenClipboard 0: EmptyClipboard: CloseClipboard
End Function
 
 
Function CopyBitmapPicture(obj As Object, Optional lPath As String = "")
    Dim IPic As IPicture, hCopy&, tIID As GUID, PictStructure As PICTDESC, x#, Ret&
    Call OpenClipboard(0): EmptyClipboard: CloseClipboard
    obj.CopyPicture Format:=xlBitmap
    OpenClipboard 0&
    x = Timer
    Do While (hCopy = 0)
        hCopy = CopyImage(GetClipboardData(&H2), 0, 0, 0, &H8)
        If Timer - x > 1 Then Exit Do
    Loop
    CloseClipboard
    If hCopy = 0 Then Set CopyBitmapPicture = IPic: Exit Function
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Set CopyBitmapPicture = IPic: Exit Function
    With PictStructure: .cbSize = Len(PictStructure): .picType = 1: .himage = hCopy: End With
    Ret = OleCreatePictureIndirect(PictStructure, tIID, 1, IPic)
    If Ret Then Set CopyBitmapPicture = IPic: Exit Function
    Set CopyBitmapPicture = IPic
    If lPath <> "" Then SavePicture IPic, lPath: Set IPic = Nothing
    OpenClipboard 0: EmptyClipboard: CloseClipboard
End Function

du coup pour le mail ça donne ça

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
Option Explicit
Sub Mail_Facturation()
    ThisWorkbook.Activate ' Évite que la macro ne se lance sur un autre fichier ouvert
    Dim Messagerie As Object, Email As Object, Objet$, Message$, Plage As Range, Image$, f As Worksheet
 
    Set f = ThisWorkbook.Sheets("Facturation")
 
    If MsgBox("Envoyer un mail au contentieux ? ", vbYesNo + vbQuestion, "Facturation") = vbYes Then
 
        Image = Environ("TEMP") & "\Image.jpg"
        '-------------------------------------------------------------------------------------
        'Message du mail
        Message = "<span style='font-family: Calibri Light; font-size: 11pt;'>" & _
                   "Bonjour,<br><br>" & _
                   "Avons-nous reçu les paiements ? Voir colonne Etat<br><br>" & _
                   "Meilleures salutations<br>" & _
                   Application.UserName & "<br><br></span>" & _
                   "<img src='" & Mid(Image, InStrRev(Image, "\") + 1) & "' alt='Image'>"
        '-------------------------------------------------------------------------------------
 
        Application.ScreenUpdating = True ' Forcer à true sinon l'image sera blanche
        '-------------------------------------------------------------------------------------
 
        'le tableau a copier
        Set Plage = Range("TS_Facturation[[#headers],[#data],[Année]:[Descriptif]]")
 
        If WorksheetFunction.CountA(Plage.Columns(1)) > 2 Then
            Set Plage = Plage.Resize(Plage.Rows.Count + Plage.Row - 2).Offset(-Plage.Row + 2)
        Else 'si il n'y a pas de dats dans le TS
            Set Plage = f.[a2].Resize(Plage.Row - 2, Plage.Columns.Count)
        End If
        '-------------------------------------------------------------------------------------
 
        CopyBitmapPicture Plage, Image
        'Object Mail Outlook
        'Objet du mail
        Objet = "Fichier de facturation mise à jour des sommes reçues - " & CStr(f.Range("Cell_Facturation_Cmde").Text) & " - " & CStr(f.Range("Cell_Facturation_Adresse").Text)
        ' Création session Outlook
        Set Messagerie = CreateObject("Outlook.Application")
        Set Email = Messagerie.CreateItem(0)
        With Email
            .To = "contentieux@zurbuchensa.ch"
            .CC = ""
            .Subject = Objet
            .Attachments.Add Image ' une premiere fois pour qu'il soit dipo sur le serveur du mail
            .Attachments.Add Image ' une 2d fois si on veux qu'elle soit en piece jointe aussi
            .HTMLBody = Message
            .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 Plage = Nothing
End Sub

cela dit je suis intéressé de savoir quelle fonction de quelle dll tu passe de copy a png dans ta passerelle dll
je pourrait faire une 3eme fonction png
comme ça j'aurais WMF , JPG , PNG avec api

[jurassic pork]

Hello pat,

Bonjour jurassic pork
cela dit je suis intéressé de savoir quelle fonction de quelle dll tu passe de copy a png dans ta passerelle dll
je pourrait faire une 3eme fonction png
comme ça j'aurais WMF , JPG , PNG avec api

je n'utilise pas d' API windows dans ma dll mais des classes et des fonctions dotnet

[goninph]

Bonsoir goninph
j'ai testé ma solution sur 2007 2013 2016 et 2021
et je n'ai eu aucun problème
2 solutions
soit ton fichier est corrompu dans le Core.xml voir dans les xml des feuilles
soit tu a un sérieux problème de librairie

veux tu bien tester celui ci comme ça on sera fixé

Ouvert 10x sans soucis

Je suis allé boire un café et de retour il a planté

[patmeziere]

Quelle version a tu essayé ?

[goninph]

Le fichier ci-dessous 08/11/2024 et le mien
J'ai ajouté Error Goto Fin pour ne plus perdre de temps si le mail n'est pas créé je clique une nouvelle fois

[patmeziere]

Bonjour goninph
essaie cette version pour voir
je t'ai mis ma fonction objectToimagePNG avec chart

[goninph]

Merci pour cette variante qui fonctionne sur mon PC perso.

Il y a un problème, c'est que les cellules sans fond sont transparentes dans l'image et l'mage posée sur un fond noir ou une autre couleur ce n'est pas top.

Comment rendre les cellules transparentes Excel avec fond blanc dans l'image ?

Ce week, je testerai avec mon PC pro

[patmeziere]

Bonsoir goninph

les range ne seront plus transparentes

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
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
                If TypeOf ObjectOrRange Is Range Then
                    .ChartArea.Format.Fill.transparency = 1
                    Else: .ChartArea.Format.Fill.transparency = 0.99
                End If
            Else
                .ChartArea.Format.Fill.transparency = 0
            End If
            .Export cheminx, Split(cheminx, ".")(1)
        End With
    End With
    Graph.Parent.Delete
    CopyOBJECTInImagePNG = cheminx
End Function

[goninph]

merci, mais toujours transparente

[patmeziere]

re
a ben vla que je fait les choses a l'envers maintenant

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
Sub test()
CopyOBJECTInImagePNG ActiveSheet.UsedRange.Resize(, [o1].Column), Environ("userprofile") & "\desktop\monimage.png"
End Sub
 
Function CopyOBJECTInImagePNG(ObjectOrRange, _
                              Optional cheminx As String = "", _
                              Optional transparency As Boolean = False) 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
                If TypeOf ObjectOrRange Is Range Then
                      .ChartArea.Format.Fill.transparency = 0.1
             Else:
                    .ChartArea.Format.Fill.transparency = 1
                     End If
            Else
                .ChartArea.Format.Fill.transparency = 0
            End If
            .Export cheminx, Split(cheminx, ".")(1)
        End With
    End With
    Graph.Parent.Delete
    CopyOBJECTInImagePNG = cheminx
End Function

[goninph]

en supprimant ce code, ça fonctionne aussi ...

A qoui sert ce code ?

Code :

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

1
2
3
4
5
6
7
8
9
'            If transparency Then
'                If TypeOf ObjectOrRange Is Range Then
'                    .ChartArea.Format.Fill.transparency = 1
'                    Else:
'                    .ChartArea.Format.Fill.transparency = 0.99
'                End If
'            Else
'                .ChartArea.Format.Fill.transparency = 0
'            End If