copy shape image into image control

[Luc Benninger]

I got a sheet with several pictures. Inserted by Insert / Picture / From
File. Now I'm trying to create a VBA userform which shows small-sized
versions of these images. Is there a way of getting an image from a shape
into a userforms image control picture property?
thanks a lot, Luc

 

[Michel Pierron]

Hi Luc,
You can test something like:

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

Private Declare Function OpenClipboard& Lib _
"user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function GetClipboardData& Lib _
"user32" (ByVal wFormat%)
Private Declare Function SetClipboardData& Lib _
"user32" (ByVal wFormat&, ByVal hMem&)
Private Declare Function CloseClipboard& Lib "user32" ()
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
Private Declare Function DestroyIcon& Lib "user32" (ByVal hIcon&)

' Copy sheet picture to UserForm
Private Sub CommandButton1_Click()
If nbPictures = 0 Then Exit Sub
ThisWorkbook.Sheets(1).Shapes("Picture 1").CopyPicture 1, 2
Call ImageToMePicture
End Sub

Private Function nbPictures() As Integer
nbPictures = ThisWorkbook.Sheets(1).Shapes.Count
If nbPictures = 0 Then MsgBox "Aucune image trouvée !", 64
End Function

Private Sub ImageToMePicture()
Dim hCopy&: OpenClipboard 0&
' Bitmap = 2 / Metafile = 14
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
' Bitmap = 1 / Metafile = 4
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
'Me.Picture = LoadPicture("")
'Me.Picture = IPic
Me.Image1.Picture = LoadPicture("")
Me.Image1.Picture = iPic
' Save picture as file (Metafichier -> c:\xxx.wmf)
'SavePicture iPic, "c:\xxx.bmp"
Set iPic = Nothing
End Sub

' Copy UserForm picture to sheet
Private Sub CommandButton3_Click()
Dim iPic As StdPicture, hCopy&
'Set iPic = Me.Picture
Set iPic = Me.Image1.Picture
OpenClipboard 0&: EmptyClipboard
hCopy = SetClipboardData(2, iPic.handle)
CloseClipboard
If hCopy Then
ActiveSheet.Cells(1, 1).Select
ActiveSheet.Paste
' Save picture as file (Metafichier -> c:\xxx.wmf)
'SavePicture iPic, "c:\xxx.bmp"
End If
DestroyIcon iPic.handle
Set iPic = Nothing
End Sub

MP

 

[pqillu]

Thank you Michel Pierron for your code. I had the same problem and i
has been solved pasting your code.

PQill

 

[tlanzolteotl]

Thank you, Mr Michel Pierron for your code... was a powerfull... thank you