XL 2013 Insérer dans un USF une image qui est dans une feuille

'Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PicDesc, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PicDesc, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long

'capturer une plage en bitmap et créer une image en memoire (Ipicture)pour
's'en servir dans un control image dans un userform
'patricktoulon sur developpez.com
'utilisation d'un  clisd pour la structure IPictureIID
'date/22/03/2010
'remasteurisation du code date: 12/09/2023
' api creation object image
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" (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 CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) 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 CreateIpictureCopyBitMapToClip(obj As Object)
    Dim IPic As IPicture, hCopy&, tIID As GUID, PictStructure As PICTDESC, x#, Ret&
    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 CreateIpictureCopyBitMapToClip = IPic: Exit Function
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Set CreateIpictureCopyBitMapToClip = IPic: Exit Function
    With PictStructure: .cbSize = Len(PictStructure): .picType = 1: .himage = hCopy: End With
    Ret = OleCreatePictureIndirect(PictStructure, tIID, 1, IPic)
    If Ret Then Set CreateIpictureCopyBitMapToClip = IPic: Exit Function
    Set CreateIpictureCopyBitMapToClip = IPic
    Call OpenClipboard(0): EmptyClipboard: CloseClipboard
End Function

Function copyxlPicture(obj) 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(14), vbNullString)
        If Timer - T > 1 Then Exit Do
    Loop
    CloseClipboard
    If hCopy = 0 Then Set copyxlPicture = IPic: Exit Function    ' si pas de handleimage WMF dans clip on arrete tout
    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
End Function

Me.Image1.picture=CreateIpictureCopyBitMapToClip(object  à  copier)'jpg
Me.Image1.picture=copyxlPicture(object  à  copier)'wmf