Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormatW Lib "user32" (ByVal lpszFormat As LongPtr) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal Format As Long) As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
Private Declare PtrSafe Function CopyMetaFileA Lib "gdi32" (ByVal hmf As LongPtr, ByVal lpFileName As String) As LongPtr
Private Declare PtrSafe Function DeleteMetaFile Lib "GDI32.dll" (ByVal hmf As LongPtr) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As LongPtr) As Long
Private 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
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (Destination As Any, ByVal Source As LongPtr, ByVal Length As LongPtr)
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(&HE), vbNullString)
If Timer - T > 1 Then Exit Do
Loop
CloseClipboard
If hCopy = 0 Then Set copyxlPicture = ipic: Exit Function
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 copyObjToEmfFile(obj As Object, Optional cheminX = "")
Dim hMeta As LongPtr, hCopy As LongPtr
If cheminX = "" Then cheminX = ThisWorkbook.Path & "\captureObject.emf"
obj.CopyPicture
If OpenClipboard(0) Then
hMeta = GetClipboardData(&HE)
If hMeta <> 0 Then hCopy = CopyEnhMetaFileA(hMeta, cheminX)
DeleteEnhMetaFile hCopy
End If
CloseClipboard
copyObjToEmfFile = cheminX
End Function
Function CopyBitmapPicture(obj As Object, Optional lPath As String = "")
Dim ipic As IPicture, hCopy As LongPtr, tIID As GUID, PictStructure As PICTDESC, x#, ret As LongPtr
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
Public Function CopyPngPicture(obj As Object, lPath As String, Optional RangeTransparency As Boolean = False) As Variant
Dim i&, hClipMemory As LongPtr, lpClipMemory As LongPtr, memSize As Long, apiRetVal As Long, dataFormat, tmpBuffer() As Byte
If TypeName(obj) = "Range" Then
obj.CopyPicture
obj.Parent.Paste
If Not RangeTransparency Then
Selection.ShapeRange.Fill.ForeColor.RGB = vbWhite
Selection.ShapeRange.Fill.Visible = True
End If
Selection.Copy
Selection.Delete
Do Until IsClipboardFormatAvailable(14) > 0 Or i > 1000: i = i + 1: DoEvents: Loop
Else
obj.Copy
End If
dataFormat = RegisterClipboardFormatW(StrPtr("PNG"))
If Not CBool(OpenClipboard(0)) Then MsgBox "L'Ouverture tu ClipBord a échoué": CopyPngPicture = False: Exit Function
If Not CBool(IsClipboardFormatAvailable(dataFormat)) Then MsgBox "Aucun Png dispo dans le clipboard": CopyPngPicture = False: Exit Function
hClipMemory = GetClipboardData(dataFormat)
If Not CBool(hClipMemory) Then MsgBox "Aucun Stream de Png dispo dans le clipboard": CopyPngPicture = False: Exit Function
memSize = GlobalSize(hClipMemory)
lpClipMemory = GlobalLock(hClipMemory)
If CBool(lpClipMemory) Then
ReDim tmpBuffer(0 To memSize - 1) As Byte
Call CopyMemory(VarPtr(tmpBuffer(0)), lpClipMemory, memSize)
apiRetVal = GlobalUnlock(hClipMemory)
Else
MsgBox " Récupération du STREAM du png a echoué": Exit Function
End If
Open lPath For Binary Access Write As #1: Put #1, 1, tmpBuffer: Close #1
CopyPngPicture = lPath
EmptyClipboard
CloseClipboard
End Function
Sub TestF()
copyObjToWmfFile2 ActiveSheet.Shapes("boule"), Environ("userprofile") & "\DeskTop\wmfboule.wmf"
End Sub
Function copyObjToWmfFile2(obj As Object, Optional cheminX = "")
Dim hMeta As LongPtr, hCopy As LongPtr, hGlobal As LongPtr
If cheminX = "" Then cheminX = ThisWorkbook.Path & "\captureObject.Wmf"
OpenClipboard (0): EmptyClipboard: CloseClipboard
obj.CopyPicture
If OpenClipboard(0) Then
If IsClipboardFormatAvailable(&H3) = 0 Then MsgBox " pas de meta dans le clip": Exit Function
hGlobal = GetClipboardData(&H3)
hMeta = GlobalLock(hGlobal): GlobalUnlock hGlobal
RtlMoveMemory hMeta, hMeta + 12, Len(hMeta)
If hMeta <> 0 Then hCopy = CopyMetaFileA(hMeta, cheminX)
If hCopy <> 0 Then DeleteMetaFile hCopy
End If
CloseClipboard
copyObjToWmfFile2 = cheminX
End Function
Sub ListClipboardDisponibleFormats()
Dim formatID As Long
OpenClipboard 0
formatID = EnumClipboardFormats(0)
Do While formatID <> 0
Debug.Print "Format disponible : " & Hex(formatID)
formatID = EnumClipboardFormats(formatID)
Loop
CloseClipboard
End Sub
