I changed your shape names to be consecutive. You did not have an "Image 3".
The attached file will do it but it is not optimal. It is all that I have time for right now. The easiest method to set the image dimensions might be to save the shape with the image control's dimensions for userform1 and then another for userform2's image control dimensions. Scaling can be a problem for images though. If you have irfanview, there is a knowledge base (kb) entry that explains how you can use it to set image dimensions.
For those that don't want to open the file, here is some code to give you an idea of what the file has.
Module2 modified:
Public liste As Range
Dim IM() As New Classe1
Sub affiche()
'Feuil2 est le CodeName de la feuille
Dim i%
Set liste = Feuil2.Range("B3:B" & Application.Match("zzz", Feuil2.[B:B]))
If liste.Row = 1 Then Exit Sub
ReDim IM(liste.Count)
On Error Resume Next 'si une photo ou un contrôle n'existent pas
With UserForm1
For i = 1 To liste.Count
If liste(i) <> "" Then
Set IM(i).IM = .Controls("Image" & i)
'.Controls("Image" & i).Picture = LoadPicture("J:\Jaquettes\" & liste(i) & ".jpg") 'chargement de l'image
'.PictureSizeMode = 3 ' 0=partiel, 1 = étirer, 3= proportionnel
End If
Next
.Show
End With
End Sub
Added mShapeToImage Module:
'Modified by Kenneth Hobson, 6/25/15, based on: http://www.mrexcel.com/forum/showthread.php?t=562721
'Declare a UDT to store a GUID for the IPicture OLE Interface
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Public Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Public Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Integer) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" _
() As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const PICTYPE_BITMAP = 1
Sub Shape_to_Image(oShape As Shape, oImage As Image, Optional sFileName As String = "")
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'Dim sTempFileName As String
'sTempFileName = ThisWorkbook.Path & "\temp.bmp"
'Copy and retrieve the handle to the range Image
oShape.CopyPicture xlScreen, xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'Create the interface GUID for the picture
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
' Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hPtr ' Handle to image.
.hPal = 0 ' Handle to palette (if bitmap).
End With
'Create the Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'oImage.Picture = ""
oImage.Picture = IPic
'Save Picture Object to disk.
If sFileName = "" Then sFileName = ThisWorkbook.Path & "\temp.bmp"
stdole.SavePicture IPic, sFileName
'Comment.Shape.Fill.UserPicture sTempFileName
End Sub
Initialize event added to Userform1:
Private Sub CommandButton1_Click() Unload Me
End Sub
' WIA, https://msdn.microsoft.com/en-us/library/windows/desktop/ee663303(v=vs.85).aspx
' Using WIA Filters, http://msdn.microsoft.com/en-us/library/ms630819%28VS.85%29.aspx
' Early binding requires Tools > References > Microsoft Windows Image Acquisition Library v2.0
' c:\windows\system32\wiaaut.dll
' WIA method to get height, width and such, are read only properties.
Private Sub UserForm_Initialize()
Dim i As Integer, fn As String
On Error Resume Next
For i = 1 To 8
fn = ThisWorkbook.Path & "\Image " & i & ".bmp"
Shape_to_Image Worksheets("DATABASE").Shapes("Image " & i), Me.Controls("Image" & i), fn
Me.Controls("Image" & i).Picture = LoadPicture(fn)
Next i
End Sub
No change to Classe1:
Option ExplicitPublic WithEvents IM As MSForms.Image
Private Sub IM_Click()
Dim i%, j As Byte
i = Val(Replace(IM.Name, "Image", ""))
For j = 1 To 12
UserForm2.Controls("TextBox" & j) = Feuil2.Cells(i + 2, j).Text
Next
UserForm2.Image1.Picture = UserForm1.Controls("Image" & i).Picture
UserForm1.Hide
UserForm2.Show
End Sub
Private Sub IM_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim i%
With UserForm1.TextBox1
.Visible = False
If X > 10 And X < IM.Width - 10 And Y > 10 And Y < IM.Height - 10 Then
i = Val(Replace(IM.Name, "Image", ""))
.AutoSize = False
.Value = Join(Array(liste(i), liste(i, 2), liste(i, 3), liste(i, 4), _
liste(i, 5), liste(i, 8), liste(i, 9), liste(i, 10), liste(i, 11)), vbLf)
.Width = 1000
.AutoSize = True
.Width = .Width + 5
.Left = X + IM.Left - .Width / 2
If .Left < 0 Then .Left = 0
If .Left + .Width > .Parent.Width Then .Left = .Parent.Width - .Width
.Top = Y + IM.Top + 10
.Visible = True
End If
End With
End Sub
Reply With Quote
M
Originally Posted by SamT
