Enregistrer un graphique en .gif

 Dim Chemin As String
 Chemin = ThisWorkbook.Path & "\mongraph.gif"
  Sheets("Feuil1").ChartObjects("Graphique 2").Chart.Export Chemin, "GIF"
   Image1.Picture = LoadPicture(Chemin)
   Kill Chemin

Option Explicit

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Type UPICDESC
   Size As Long
   Type As Long
   hPic As Long
   hPal As Long
End Type

Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (ByRef pPicDesc As UPICDESC, ByRef RefIID As GUID, ByVal fOwn As Long, ByRef IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub CommandButton1_Click()
Dim BmpFile As String
   
   OpenClipboard 0: EmptyClipboard: CloseClipboard
   With ActiveSheet.Shapes("Graphique 1")
      .Copy
   End With
   DoEvents
   Sleep 200
   SaveBmp BmpFile
   Image1.Picture = LoadPicture(BmpFile)
   Kill BmpFile
End Sub

Public Sub SaveBmp(BmpFile As String) 'Michel PIERRON
On Error GoTo Fin
Dim oPic As IPictureDisp
'http://www.generation-nt.com/reponses/graphique-feuille-excel-userform-entraide-89373.html#353430
   BmpFile = ThisWorkbook.Path & "\Temp.bmp"
   Set oPic = PasteBmp: SavePicture oPic, BmpFile
   Set oPic = Nothing: Exit Sub
Fin:    MsgBox "Image non trouvée !", 48
End Sub

Public Function PasteBmp() As IPicture 'Michel PIERRON
Dim hCopy As Long
'http://www.generation-nt.com/reponses/graphique-feuille-excel-userform-entraide-89373.html#353430
   If IsClipboardFormatAvailable(2) Then
      If OpenClipboard(0&) Then
      hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
      CloseClipboard
      If hCopy Then Set PasteBmp = CreateBmp(hCopy, 0, 2)
      End If
   End If
End Function

Public Function CreateBmp(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture 'Michel PIERRON
Dim i As Long, PicInfo As UPICDESC, OlePicStore As GUID, IPic As IPicture
'http://www.generation-nt.com/reponses/graphique-feuille-excel-userform-entraide-89373.html#353430
   With OlePicStore
      .Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A
      For i = 1 To 8
         .Data4(i - 1) = Choose(i, &H8B, &HBB, &H0, &HAA, &H0, &H30, &HC, &HAB)
      Next i
   End With
   With PicInfo
      .Size = Len(PicInfo)
      .Type = 1
      .hPic = hPic
      .hPal = hPal
   End With
   If OleCreatePictureIndirect(PicInfo, OlePicStore, True, IPic) Then MsgBox "Impossible de créer le bitmap !", 48
   Set CreateBmp = IPic
End Function