Option Explicit
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As LongPtr
Declare PtrSafe Function copyimage Lib "user32" Alias "CopyImage" (ByVal handle As LongPtr, ByVal un1 As LongPtr, ByVal n1 As LongPtr, ByVal n2 As LongPtr, ByVal un2 As LongPtr) As LongPtr
Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
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 copyimagex(obj)
Dim IPic As IPicture
Dim hCopy As LongPtr
Dim tIID As GUID
Dim PictStructure As PICTDESC
Dim x As Double
Dim Ret As LongPtr
Call OpenClipboard(0): EmptyClipboard: CloseClipboard
obj.Copy
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 copyimagex = IPic: Exit Function
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Set copyimagex = IPic: Exit Function
With PictStructure: .cbSize = Len(PictStructure): .picType = 1: .himage = hCopy: End With
Ret = OleCreatePictureIndirect(PictStructure, tIID, 1, IPic)
If Ret Then Set copyimagex = IPic: Exit Function
Set copyimagex = IPic
Call OpenClipboard(0): EmptyClipboard: CloseClipboard
Set copyimagex = IPic
End Function
