picture in userform

Hiiiii....
hiiii forum..members
Please how can we display in USF1 with spinbutton also detail the image of each named after the sheet (DATABASE)
thank you in advance
cordially
GAVIOTA
Attachment 13626

1. This uses PastePicture(xlPicture) from STEPHEN BULLEN, Office Automation Ltd

2. I also changed 4 of your text boxes to labels, since it appeared they were not intended to be updated

3. The only tricky thing to locate the image is that the top left corner of the image HAS to be in the proper row and in column 5. Other ways to do it, but it seems you wanted the image on the worksheet

Code:

---

Option Explicit
Dim aImages() As String
Dim rData As Range
Dim iDisplay As Long
Private Sub SpinButton1_SpinUp()
    iDisplay = iDisplay + 1
    If iDisplay > Me.SpinButton1.Max Then iDisplay = Me.SpinButton1.Min
    pvtRefresh
End Sub
Private Sub SpinButton1_SpinDown()
    iDisplay = iDisplay - 1
    If iDisplay < Me.SpinButton1.Min Then iDisplay = Me.SpinButton1.Max
    pvtRefresh
End Sub
Private Sub UserForm_Initialize()
    Dim i As Long
    Dim oShape As Shape
   
    Set rData = Worksheets("DATABASE").Cells(1, 1).CurrentRegion
    Me.SpinButton1.Min = 2
    Me.SpinButton1.Max = rData.Rows.Count
    ReDim aImages(Me.SpinButton1.Min To Me.SpinButton1.Max)
   
    For Each oShape In Worksheets("DATABASE").Shapes
        For i = 2 To rData.Rows.Count
            If oShape.TopLeftCell.Row = i And oShape.TopLeftCell.Column = 5 Then
                aImages(i) = oShape.Name
                Exit For
            End If
        Next i
    Next
    iDisplay = 2
    Me.SpinButton1.Value = iDisplay
    pvtRefresh
End Sub

Private Sub pvtRefresh()
    With Me
        .TextBox5.Text = rData.Cells(iDisplay, 1).Value
        .TextBox6.Text = rData.Cells(iDisplay, 2).Value
        .TextBox7.Text = rData.Cells(iDisplay, 3).Value
        .TextBox8.Text = rData.Cells(iDisplay, 4).Value
       
        If Len(aImages(iDisplay)) > 0 Then
            Worksheets("DATABASE").Shapes(aImages(iDisplay)).Copy
            Set Image1.Picture = PastePicture(xlPicture)
        End If
   
    End With

End Sub

---

Quote:

---

Originally Posted by Paul_Hossler

1. This uses PastePicture(xlPicture) from STEPHEN BULLEN, Office Automation Ltd

2. I also changed 4 of your text boxes to labels, since it appeared they were not intended to be updated

3. The only tricky thing to locate the image is that the top left corner of the image HAS to be in the proper row and in column 5. Other ways to do it, but it seems you wanted the image on the worksheet

Code:

---

Option Explicit
Dim aImages() As String
Dim rData As Range
Dim iDisplay As Long
Private Sub SpinButton1_SpinUp()
    iDisplay = iDisplay + 1
    If iDisplay > Me.SpinButton1.Max Then iDisplay = Me.SpinButton1.Min
    pvtRefresh
End Sub
Private Sub SpinButton1_SpinDown()
    iDisplay = iDisplay - 1
    If iDisplay < Me.SpinButton1.Min Then iDisplay = Me.SpinButton1.Max
    pvtRefresh
End Sub
Private Sub UserForm_Initialize()
    Dim i As Long
    Dim oShape As Shape
   
    Set rData = Worksheets("DATABASE").Cells(1, 1).CurrentRegion
    Me.SpinButton1.Min = 2
    Me.SpinButton1.Max = rData.Rows.Count
    ReDim aImages(Me.SpinButton1.Min To Me.SpinButton1.Max)
   
    For Each oShape In Worksheets("DATABASE").Shapes
        For i = 2 To rData.Rows.Count
            If oShape.TopLeftCell.Row = i And oShape.TopLeftCell.Column = 5 Then
                aImages(i) = oShape.Name
                Exit For
            End If
        Next i
    Next
    iDisplay = 2
    Me.SpinButton1.Value = iDisplay
    pvtRefresh
End Sub

Private Sub pvtRefresh()
    With Me
        .TextBox5.Text = rData.Cells(iDisplay, 1).Value
        .TextBox6.Text = rData.Cells(iDisplay, 2).Value
        .TextBox7.Text = rData.Cells(iDisplay, 3).Value
        .TextBox8.Text = rData.Cells(iDisplay, 4).Value
       
        If Len(aImages(iDisplay)) > 0 Then
            Worksheets("DATABASE").Shapes(aImages(iDisplay)).Copy
            Set Image1.Picture = PastePicture(xlPicture)
        End If
   
    End With

End Sub

---

---

hiii Paul_Hossler
thank you master
is flawless
I will wish
thank you a lot
it is resolved
cordially
GAVIOTA