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

 

[DanteAmor]

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

According to what you want, You don't need the RefEdit1 or OptionButton1 controls, since you always want to start at cell A1 and below.
Then try the following code.

Private Sub cmdOK_Click()
  Const cBorder = 2
  Dim vArray As Variant, vPicture As Variant, pic As Shape, rng As Range
  
  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("A1")
  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
    Set rng = rng.Offset(1, 0)
  Next vPicture
  Set pic = Nothing
  Unload Me
End Sub

 

[KlausW]

Hi DanteAmor
Is it possibel that Excel can find pictures from a range in cell I3 in sheets (Stamdata)?
That's what I do myself now.
Best Regards
Klaus W

 

[DanteAmor]

Is it possibel that Excel can find pictures from a range in cell I3 in sheets (Stamdata)?

I do not understand what you mean.

How does that relate to the macro in the original post and the macro in post #2?

If it's something new you should close this thread and create a new one.

 

[KlausW]

Hi DanteAmor

It is not new, I asked the question in #1
But perhaps a little cryptically written.

Best regards
Klaus W

 

[DanteAmor]

So I don't understand what you have in cell I3 and what you want in cell A1.

Could you illustrate it with examples?

I can't see your sheet, so please try to be very clear with the examples.
Clearly describe what you have in cell I3 and what you want in cell A1.
Support yourself with images or with what you think is convenient so that we better understand what you want and thus give you a comprehensive solution from the beginning.

 

[KlausW]

I will, in cell A1 i is where the images start being inserted. So it's solved. Thank you.

In cell I3 in sheets (Stamdata) it stand where the images are to be retrieved from. Example, D:\Excel 2023\Travel settlement\Appendix
When I run the code now I have to choose the folder where the images are to be downloaded from.
An want it to go automatically when I run VBA code.
Did that make sense?
KW

 

[KlausW]

This is what happen when I run the VBA-code now push the blue botton..

What I shout like it to be when I push the blu botton is that the images is inserted completely automatically. An the box do not coms up.

KW

 

[DanteAmor]

In cell I3 in sheets (Stamdata) it stand where the images are to be retrieved from. Example, D:\Excel 2023\Travel settlement\Appendix
When I run the code now I have to choose the folder

Thanks for the explanation, now it makes more sense with an example.

Please try the following (I think it's practically a new macro):

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 = 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 = ActiveSheet.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

 

[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