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

[erics83]

Bonjour,

Je cherche à insérer dans un userform une image. J'ai vu certains tutos ou exemples, mais impossible de le reproduire....ou alors, j'ai fait une fausse manip que je ne comprends pas...ou j'ai mal "reproduit" un code....et je n'ai pas compris comment JB manipulait les contrôle image dans son fichier "controle image.xls), donc...suis un peu "perdu", car j'ai beaucoup d'exemple avec des images enregistrées dans le disk dur, mais pas d'exemple (ou pas trouvé) sur des images dans le même fichier...
Pour faire simple (=une fois que j'aurais compris le code, je pourrais le reproduire), lorsque l'USF s'ouvre, il doit afficher l'image qui est en Feuil2....

Merci pour votre aide,

 

[Dudu2]

Alors oui ça fonctionne chez moi Office 2016 64bits / Windows 10 64 bits en remplaçant une dll.

'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

 

[patricktoulon]

ok je teste chez moi voir si celle ci fonctionne chez moi
merci @TooFatBoy

 

[Dranreb]

Ça marche mais je viens de m'apercevoir que l'image est aux dimensions du shape. Si on les a diminuées pour en faire une sorte d'icône on ne peut plus retrouver l'image détaillée. Avec une image ActiveX, si, et bien plus simplement.

 

[patricktoulon]

bon la oleaut32 fonctionne chez moi en 32
ben oui@dranreb c'est une copie du shap qui est fait forcement la copie est comme la shape au moment ou tu capture
une image dans un shapes ou une picture ne peut plus être récupérée comme à l'original
du coup j'ai fait du nettoyage
les api

'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

capture en bitmap

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

capture en wmf

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

je ne pense pas que ce soit nécessaire de vous dire
que les deux fonctions renvoient un object de type IpictureDisp

 

[patricktoulon]

du coup j'ai fait le menage dans mes vieux trucs
et j'ai remastérisé les version avec graphique
en

1. jpg
2. gif(transparence complète)
3. png(transparence complète et semi transparence )
4. sans oublier ma fétiche avec les macro4
5. ben avec ça si on me dit que l'on peut pas
   

 

[patricktoulon]

re purée regardez ce que j'ai retrouvé
alors ca c'est un de mes premiers exercice a faire joujou api/ image sur dvp
non seulement j'ai des shapes et wordarts dans mon userform mais j'ai même le rollover
purée c'est encore en xls
incroyable ca marche encore

à la base il est comme ça