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

' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|
'
'***********************************************************************************
'                           COLLECTION IMAGE ET SHAPES
'exporter un object en gif(rnange,shapes et tout autre object present sur la feuille)
'version avec LES API USER32 ET GDI DECLAREES
' version 03/05/2013
'mise  à jour:12/09/2023
'transformation en fonction
'ajout de la supression auto du fichier quand c'est pour une copie dans le userform

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 uFormat As Long) As LongPtr
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Dim cheminT
Sub supperessionWMF1()
    If Dir(cheminT) <> "" Then Kill cheminT
End Sub
Function CopyOBJECTInImageWMF1(ObjecOrRange As Object, _
                               Optional cheminx As String = "", _
                               Optional NotTransparenceRange As Boolean = False, _
                               Optional DoNotKeepFile As Boolean = False) As String
    If cheminx = "" Then cheminx = ThisWorkbook.Path & "\image.wmf"
    cheminT = cheminx
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
    ObjecOrRange.CopyPicture
    If NotTransparenceRange = True Then
        With ObjecOrRange.Parent
            .Pictures.Paste
            DoEvents
            Set ShaP = .Shapes(.Shapes.Count)
            ShaP.Fill.Visible = msoTrue
            ShaP.Fill.ForeColor.RGB = vbWhite
            'Exit Function
            ShaP.CopyPicture
            ShaP.Delete
        End With
    End If
    T = Timer
    Do: DoEvents: hpicvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")")
        If Timer - T > 2 Then Exit Do
    Loop While hpicvail = 0
    If hpicvail = 0 Then MsgBox "il y a eu un problème l'ors de la copie de l'image": CopyOBJECTInImageWMF1 = "": Exit Function

    OpenClipboard 0
    DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), cheminx)
    CloseClipboard

    CopyOBJECTInImageWMF1 = cheminx
    If DoNotKeepFile Then Application.OnTime Now, "supperessionWMF1"

End Function

Option Explicit
Private Sub UserForm_Activate()
   ShapeImg(Me.Image1) = Feuil1.Shapes(1)
   End Sub
Private Property Let ShapeImg(ByVal Img As MSForms.Image, ByVal RHS As Excel.Shape)
Rem. Inspiré d'un code de patricktoulon
   Dim FicTemp As String, HImg As LongPtr, HEMF As LongPtr
   ExecuteExcel4Macro "CALL(""user32"",""OpenClipboard"",""JJ"",0)"
   ExecuteExcel4Macro "CALL(""user32"",""EmptyClipboard"",""J"")"
   ExecuteExcel4Macro "CALL(""user32"",""CloseClipboard"",""J"")"
   RHS.CopyPicture
   DoEvents
   Do While ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC"",14)") = 0
      If MsgBox("Instruction: Shapes(""" & RHS.Name & """).CopyPicture" & vbLf & _
         "Le presse papier ne semble pas recevoir l'image.", _
         vbRetryCancel, "Property Set ShapeImg") = vbCancel Then Exit Property
      Loop
   ExecuteExcel4Macro "CALL(""user32"",""OpenClipboard"",""JJ"",0)"
   HImg = ExecuteExcel4Macro("CALL(""user32"",""GetClipboardData"",""JJ"",14)")
   FicTemp = Environ$("UserProfile") & "\DeskTop\Temp.wmf"
   HEMF = ExecuteExcel4Macro("CALL(""gdi32"",""CopyEnhMetaFileA"",""JJC""," & HImg & ",""" & FicTemp & """)")
   ExecuteExcel4Macro "CALL(""gdi32"",""DeleteEnhMetaFile"",""JJ""," & HEMF & ")"
   ExecuteExcel4Macro "CALL(""user32"",""CloseClipboard"",""J"")"
   Img.Picture = LoadPicture(FicTemp): Kill FicTemp
   End Property

'Types de données pour type_string: argument(chaîne_type)

'B - nombre à virgule flottante de 8 octets (IEEE), transféré par valeur, type C double.

'C - Chaîne terminée par zéro (null) (longueur max. = 255 caractères), transférée par référence, type C char *

'F - Chaîne terminée par zéro (null) (longueur max. = 255 caractères), transférée par référence (modifier sur place) , Type C char *

'J - entier signé de 4 octets de large, transféré par valeur, type C long int

'P - structure de données OPER d'Excel, transféré par référence, type C OPER *

'R - structure de données XLOPER d'Excel, transféré par référence, type C XLOPER *

'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
' api creation object image
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'rectangle
Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
'guid all propertie pour le jpg
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(8) As Byte: End Type
' info image
Private Type PICTDESC: cbSize As Long: picType As Long: hImage As Long: End Type

Sub test()    'teste pour voir un range dans l'userform
    EmptyClipboard
    Range("A1:c8").Copy
    LaisseLeClipboardDigérer
    With UserForm1
        .Show 0
        .Image1.Picture = TakePictureOnClipboard
    End With
End Sub 'nouveau on utilise le clisd pour la creation du conteneur BIPMAP
'reduction considerable du code
'Attention !!fonctionne que pour du BITMAP PAS POUR DU (WMF(XLPICTURE))
Function TakePictureOnClipboard()
    Dim iPic As IPicture, hCopy&, tIID As GUID, tPICTDEST As PICTDESC
    OpenClipboard 0&
    hCopy = CopyImage(GetClipboardData(&H2), 0, 0, 0, &H8)
    CloseClipboard
    If hCopy = 0 Then Exit Function
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    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
    Set TakePictureOnClipboard = iPic
End Function

Function LaisseLeClipboardDigérer()
    Dim hPicAvail
    x = Timer
    Do While hPicAvail = 0
        hPicAvail = IsClipboardFormatAvailable(2) '2 pour le format bitmap
        If Timer - x > 1 Then Exit Do
    Loop
    LaisseLeClipboardDigérer = hPicAvail = 1
End Function

SavePicture iPic, Environ("userprofile") & "\DeskTop\monimage.bipmap"

Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
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 OpenClipboard Lib "user32" (ByVal Hclip As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Private Type PicDesc: Size As Long: Type As Long: hPic As LongPtr: hPal As LongPtr: End Type

Function copyxlPicture(obj) As IPicture
    Dim hCopy As LongPtr, Pictstructure As PicDesc, 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: .Size = Len(Pictstructure): .Type = 4: .hPic = hCopy: .hPal = 0: End With

    OleCreatePictureIndirect Pictstructure, DispatchInfo, True, IPic
    
    Set copyxlPicture = IPic
End Function

userform1.Image1.picture=copyxlPicture(activesheet.shapes("blablabla"))