Change Useform, VBA code

[KlausW]

Hi

Anyone who can help modify this Useform, VBA code?

What I would like it to do is to start by inserting images in cell A1 and below.

And retrieve them from cell I3 in sheets (Stamdata)

Any help will be appreciated

Best regards

Klaus W

Option Explicit

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    Const cBorder = 2
    Dim vArray As Variant, vPicture As Variant, pic As Shape, rng As Range
    If Me.RefEdit1 = "" Then
        Me.RefEdit1.SetFocus
        MsgBox "Please select a cell, then try again.", vbExclamation
        Exit Sub
    End If
    vArray = Application.GetOpenFilename(FileFilter:="Pictures (*.png; *.jpg; *.jpeg; *.tif), *.png; *.jpg; *.jpeg; *.tif", _
        Title:="Select Picture to Import", MultiSelect:=True)
    If Not IsArray(vArray) Then
        MsgBox "You didn't select any pictures. Please try again.", vbExclamation
        Exit Sub
    End If
    Set rng = Range(Me.RefEdit1).MergeArea
    For Each vPicture In vArray
        Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
                Left:=rng.Left + cBorder, Top:=rng.Top + cBorder, Width:=-1, Height:=-1)
        With pic
            .LockAspectRatio = False
            .Width = rng.Width - 2 * cBorder
            .Height = rng.Height - 2 * cBorder
            .Placement = xlMoveAndSize
        End With
        If Me.OptionButton1 Then
            Set rng = rng.Offset(1, 0)
        Else
            Set rng = rng.Offset(0, 1)
        End If
    Next vPicture
    Set pic = Nothing
    Unload Me
End Sub

Private Sub UserForm_Click()

End Sub

 

[jolivanes]

If I3 in Stamdata is a path and you want all the pictures that have a jpg or jpeg extension from that folder then something like this would work.

Sub Get_All_Pictures()
Dim i As Long, sht As Worksheet, fldr As String, shpFile As String
i = 1
Set sht = Worksheets("Sheet1")    '<---- Sheet name where picyures go. Change as required.
fldr = Worksheets("Stamdata").Range("I3").Value & Application.PathSeparator
shpFile = Dir(fldr & "*.jp*")
Do While shpFile <> ""
    sht.Shapes.AddPicture(fldr & shpFile, 0, -1, Cells(i, 1).Left, Cells(i, 1).Top, Cells(i, 1).Width, Cells(i, 1).Height).Name = "Picture " & i
shpFile = Dir
i = i + 1
Loop
End Sub

 

[KlausW]

Hi Dante, unfortunately it doesn't work. The images do not appear. I will return tomorrow, it is late in Denmark
Best Regards Klaus W

 

[KlausW]

Dear DanteAmor thank you very much for your help. I choose to use the solution that jolivanes has made. Thank you for the cooperation, good day to you from me in Denmark.
Best Regards KlausW

 

[KlausW]

KW

 

[DanteAmor]

Thank you for the cooperation, good day to you from me in Denmark.
Best Regards KlausW

My macro requires a simple change.
I adjusted the name of the sheets. They are highlighted in blue. Also the macro includes other image types that you put in your original post(FileFilter:="Pictures (*.png; *.jpg; *.jpeg; *.tif)..)

Please try again:

Private Sub cmdOK_Click()
  Const cBorder = 2
  Dim vArray As Variant, vPicture As Variant, pic As Shape, rng As Range
  Dim sPath As String, s As String
  
  sPath = Sheets("Stamdata").Range("I3").Value
  If sPath = "" Then Exit Sub
  If Dir(sPath, vbDirectory) = "" Then Exit Sub
  If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
  Set rng = Range("A1")
  s = Dir(sPath & "*.*")
  Do While s <> ""
    If LCase(s) Like "*.png" Or LCase(s) Like "*.jpg" Or _
       LCase(s) Like "*.jpeg" Or LCase(s) Like "*.tif" Then
      Set pic = Sheets("Sheet1").Shapes.AddPicture(Filename:=sPath & s, _
          LinkToFile:=False, SaveWithDocument:=True, _
          Left:=rng.Left + cBorder, top:=rng.top + cBorder, Width:=-1, Height:=-1)
      With pic
        .LockAspectRatio = False
        .Width = rng.Width - 2 * cBorder
        .Height = rng.Height - 2 * cBorder
        .Placement = xlMoveAndSize
      End With
      Set rng = rng.Offset(1, 0)
    End If
    s = Dir()
  Loop
  Set pic = Nothing
  Unload Me
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

 

[jolivanes]

As you can see in Dante Amor's code, there can be, as you no doubt know, all kind of picture files that have different extensions.
I prefer to have only pictures in the folder and that way I don't need to worry about extensions.
If you're inclined to go that way, change this

shpFile = Dir(fldr & "*.jp*")

to this

shpFile = Dir(fldr & "*.*")

 

[KlausW]

Hi Dante Armor thanks I can use both solutions.
Many greetings Klaus from Denmark