Picture in a worksheet

[nadiminti]

I have loaded several pictures in a worksheet "Pictures"

The pictures are inserted in the worksheet by simple copy paste.

On a userform, I am trying to load the picture by using this code

<code>
Private Sub UserForm_Initialize()
Image2.Picture = Worksheets("Pictures").OLEObjects("Picture 1").Object.Picture
End Sub
</code>

It is not loading and giving error.

Please help on how could I do it.

 

[Jaafar Tribak]

Hmm.. could you provide me the code please... in your link it is some thing related to your case. For my problem, what would be the code?

I don't have time right now ... I'll see if I can post some code later

 

[Jaafar Tribak]

See if this works for you :

1- In a Standard Module :

Option Explicit

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Const CF_ENHMETAFILE = 14
Const PICTYPE_ENHMETAFILE = 4
Const S_OK = 0


#If VBA7 Then
    Type uPicDesc
        Size As Long
        Type As Long
        hPic As LongPtr
        hPal As LongPtr
    End Type
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Dim hPtr As LongPtr
#Else
    Type uPicDesc
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    Declare Function OpenClipboard Lib "user32"(ByVal hwnd As Long) As Long
    Declare Function GetClipboardData Lib "user32"(ByVal wFormat As Integer) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function IsClipboardFormatAvailable Lib "user32"(ByVal wFormat As Integer) As Long
    Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Dim hPtr As Long
#End If
 
Function GetPictureObject(Shape As Shape) As IPicture
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    
    Shape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    If IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0 Then
        OpenClipboard 0
        hPtr = GetClipboardData(CF_ENHMETAFILE)
        CloseClipboard
        If hPtr <> 0 Then
            With IID_IDispatch
                .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 uPicinfo
                .Size = Len(uPicinfo)
                .Type = PICTYPE_ENHMETAFILE
                .hPic = hPtr
                .hPal = 0
            End With
            If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic) = S_OK Then
                Set GetPictureObject = IPic
            End If
        End If
    End If
End Function

2- In the UserForm Module :

Option Explicit


Private Sub UserForm_Initialize()
    Image2.Picture = GetPictureObject(Worksheets("Pictures").Shapes("Image1"))
End Sub