'**********************************************************************************
' __ _____ ___ . ___ _____ ___ ___
'|__| /\ | | | | | | / | | | | | | | | |\ |
'| /__\ | |--- | | |/\ | | | | | | | | | \ |
'| / \ | | \ | |___ | \ | |___| |___| |__ |___| | \|
'
'***********************************************************************************
' COLLECTION IMAGE ET SHAPES
'exporter un object en gif(rnange,shapes et tout autre object present sur la feuille)
'version avec graphique 1.1
'date version 03/05/2016
'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)
'**********************************************************************************
Option Explicit
Sub export_Range_To_Image()
Dim fichier$
fichier = ThisWorkbook.Path & "\imagetemp.gif"
ExportOBJECTInImage [Feuil1!A1:F10], fichier
End Sub
Sub export_Object_To_Image()
Dim fichier$
fichier = ThisWorkbook.Path & "\ImageObjectTemp.gif"
ExportOBJECTInImage ActiveSheet.Shapes("Boule"), fichier
End Sub
Function ExportOBJECTInImage(ObjecOrRange, CheminX As String)
Dim chart1 As Object, hPicAvail As Long
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With 'on vide le clipboard entre chaque copie pour tester vraiment le available
ObjecOrRange.CopyPicture
Set chart1 = ObjecOrRange.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
With chart1
With .Parent
.Width = ObjecOrRange.Width: .Height = ObjecOrRange.Height: .Left = ObjecOrRange.Width + 20:
'*****************************************************************************
'suppression de la gestion d'attente avec l'api IsClipboardFormatAvailable
'Do: DoEvents
'hPicAvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")") '2 pour bitmap,14 pour wmf
' Loop While hPicAvail = 0
'*********************************************************************************************
.Select
'**************************************************************
'on va paster directement dans le chart tant que le .pictures.count du chart est égal à zero
Do: DoEvents
.Chart.Paste
Loop While .Chart.Pictures.Count = 0
'************************************************************
.Chart.Export CheminX, "jpg"
End With
End With
chart1.Parent.Delete
ExportOBJECTInImage = CheminX
End Function