I put 5 pictures in Sheet1.
They were named "Picture 1", "Picture 2", ..., "Picture 5" (note the space
character).
Then I created a small userform with 2 commandbuttons (commandbutton1 and
commandbutton2) and a single image control (Image1).
This code goes in a General module:
Option Explicit
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type
Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Declare Function CloseClipboard& Lib "user32" ()
Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String _
, ByRef lpiid As GUID) As Long
Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long
' picTypeConstants:
' None = 0 / Bitmap = 1 / Metafile = 2 / Icon = 3 / EMetafile = 4
This code goes behind the userform:
Option Explicit
Dim WhichImage As Long
Private Sub CommandButton1_Click()
'Prev button
WhichImage = WhichImage - 1
If WhichImage = 0 Then
WhichImage = 5
End If
Call DoTheWork(WhichPicNumber:=WhichImage)
End Sub
Private Sub CommandButton2_Click()
'Next button
WhichImage = WhichImage + 1
If WhichImage = 6 Then
WhichImage = 1
End If
Call DoTheWork(WhichPicNumber:=WhichImage)
End Sub
Private Sub UserForm_Initialize()
With Me.CommandButton1
.Caption = "Prev"
End With
With Me.CommandButton2
.Caption = "Next"
End With
End Sub
Sub DoTheWork(WhichPicNumber As Long)
ThisWorkbook.Worksheets("Sheet1") _
.Shapes("Picture " & WhichPicNumber).CopyPicture xlScreen, xlBitmap
Dim hCopy&
OpenClipboard 0&
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)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
Me.Image1.Picture = iPic
'UserForm1.Image1.Picture = IPic
Set iPic = Nothing
' UserForm1.Show
End Sub
=================
The code that does all the real work is from Michel Pierron's post:
http://groups.google.co.uk/group/mi...d/dd2a46f0258b86b8?lnk=st&q=#dd2a46f0258b86b8
or
http://snipurl.com/30v2c [groups_google_co_uk]
