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
| Option Explicit
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 Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Public Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
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
Sub VidePP()
OpenClipboard 0
EmptyClipboard
CloseClipboard
End Sub
Sub test()
'capture en image de la selection en cours remplacer selection par un range
save_range_to_image Selection, "C:\Users\" & Environ("UserName") & "\Desktop\img.jpeg" ' ala place du chemin met sheets(X).range(xy) adapte le chemin de ta cellule
End Sub
Function save_range_to_image(plage As Range, chemin)
Dim NOM_IMAGE As Variant
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
'On copie la selection dans le clipboard
plage.Copy 'Picture xlScreen, xlBitmap 'Copie la selection dans le clipboard
'Prend l'image dans le cliboard
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H8)
CloseClipboard
If hCopy = 0 Then Exit Function
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Function
With tPICTDEST: .cbSize = Len(tPICTDEST): .picType = 1: .hImage = hCopy: End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Function
SavePicture iPic, chemin
Set iPic = Nothing
VidePP
MsgBox "capture sauvegardée sous :" & vbCrLf & chemin
End Function |
Partager