Private Sub CommandButton2_Click()
Me.Repaint
keybd_event vbKeySnapshot, 1, 0&, 0&
With ActiveSheet.ChartObjects.Add(0, 0, me.Width, me.Height).Chart
.Paste
.Export ThisWorkbook.Path & "\" & "Toto.jpg", "JPG"
End With
ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
End Sub
Sub PhotoPlage()
Dim Plage As Range
Set Plage = Range("A1:F12") 'Adapter
Plage.CopyPicture
With ActiveSheet.ChartObjects.Add(0, 0, Plage.Width, Plage.Height).Chart
.Paste
.Export ThisWorkbook.Path & "\" & "Toto.jpg", "JPG"
End With
ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete
End Sub
Me.Repaint
keybd_event vbKeySnapshot, 1, 0&, 0&
Dovents 'Pour laisser le temps que la copie se fasse
Private Sub Command1_Click()
Dim objPic As IPictureDisp
If Clipboard.GetFormat(vbCFBitmap) Then
Set objPic = Clipboard.GetData(vbCFBitmap)
SavePicture objPic, App.Path & "\toto.bmp"
End If
End Sub
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type
Public Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Public Declare Function EmptyClipboard& Lib "user32" ()
Public Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Public Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Public Declare Function CloseClipboard& Lib "user32" ()
Public Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Sub CommandButton2_Click()
Dim hCopy&
Dim iPic As IPicture
Dim tIID As GUID
Dim tPICTDEST As PICTDESC
Dim Ret As Long
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Me.Repaint
keybd_event vbKeySnapshot, 1, 0&, 0&
TT = 0.5 + Timer: Do While Timer < TT: DoEvents: Loop
' A adapter ////////////////
Chemin = ThisWorkbook.Path & "\"
Fichier = "Toto2.jpg" ' Tu peux mettre Toto3.bmp, ça fonctionne aussi (ou toto4.gif)
'///////////////////////////
OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
SavePicture iPic, Chemin & Fichier
Set iPic = Nothing
End Sub