Run without userform

[KlausW]

Hi
I have a challenge, I use this VBA code to insert images with. It works really well. It works with a userform, where I enter which cell I want to start inserting the images and whether it is in a column or in a row.
Now I would like to know if someone can help to avoid using the useform, so that I can insert the images by running the VBA code, starting in A1 and downwards.
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

 

[Micron]

I didn't think a picture could be stored in a cell; at least not without manipulating its picture properties. So I'm posting to see if anyone says otherwise, but partly to suggest that if you didn't mean to keep it within a cell, then I don't get the idea of starting with A1 and expecting that the first chosen pic will not spill over onto A2. Regardless, you need an event to trigger code and since you don't want to use a userform, then you need to specify what event you'll use. Maybe still a button click because you'll add a button to a sheet? Or maybe you'd want to put the top & left of the pic starting at the cell you made active in that click event. Or maybe you'd just want to do this when you activate a cell. Using that one would mean that your code would run whether or not you intended it to. If you see a problem with possibly having pics overlap, then you might need to remove the multiselect capability.

 

[jolivanes]

Before we get into a discussion about merged cells, are you sure you want to stick with merged areas?
They are generally seen as an "avoid at all cost". If you google something like: "Excel and using merged areas", I am sure you'll get some interesting results.
There in no problem setting a picture size to any amount of cell height and width wise.

 

[jolivanes]

This will insert all selected pictures 12 rows in height and 5 columns wide for each inserted picture.
Select as many pictures as you want by holding down the "Shift" or "Ctrl" key.

Sub Get_Multiple_Pictures()
    
    Dim Pict() As Variant
    Dim ImgFileFormat As String
    Dim sShape As Picture
    Dim i As Long, j As Long
    ActiveSheet.Protect False, False, False, False, False
    ImgFileFormat = "All Picture Files(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bpm;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg;*.pcd;*.pcx;*.cdr;*.fpx;*.mix), *.bmp"

    Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)    '<----- Select as many pictures as you want by holding down the "Shift" or "Ctrl" key.
    If Not IsArray(Pict) Then
        MsgBox "No file(s) selected. Cannot continue."
        Exit Sub
    End If

    j = 1
    
        For i = 1 To UBound(Pict)
            Set sShape = ActiveSheet.Pictures.Insert(Pict(i))
        With sShape
            .Top = Cells(j, 1).Top + 1    '<----You can delete the 1. It's just a little offset
            .Left = Cells(j, 1).Left 
            .Name = "Picture " & i
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = Columns(6).Left - 2    '<----Change the 6 to the amount of Columns each picture should cover. You can delete the 2 on this line and the next line. It's just a little offset
            .Height = Rows("1:12").Height - 2    '<---- Change 12 to amount of Rows each picture needs to cover 
        End With
        End With

        j = j + 12    '<---- Change 12 to amount of Rows each picture needs to cover 
        
        Next i
        
End Sub

 

[jolivanes]

Or if you want to stay, more or less, with what you have.

Sub Import_And_Place_Pictures()
Const cBorder = 2
Dim vArray As Variant, vPicture As Variant, pic As Shape, rng As Range, i As Long
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
i = 1
For Each vPicture In vArray
    Set rng = Cells(i, 1).Resize(12, 5)    '<---- Change the 12 and 5 to cover amount of Rows and Columns for picture size.
        Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
            Left:=rng.Left + cBorder, Top:=rng.Top + cBorder, Width:=rng.Width - 1, Height:=rng.Height - cBorder * 2)
        pic.Placement = xlMoveAndSize
    i = i + 12    '<---- Change the 12 to the same number as in the "Resize" line.
Next vPicture
Set pic = Nothing
End Sub

 

[KlausW]

Or if you want to stay, more or less, with what you have.

Sub Import_And_Place_Pictures()
Const cBorder = 2
Dim vArray As Variant, vPicture As Variant, pic As Shape, rng As Range, i As Long
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
i = 1
For Each vPicture In vArray
    Set rng = Cells(i, 1).Resize(12, 5)    '<---- Change the 12 and 5 to cover amount of Rows and Columns for picture size.
        Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
            Left:=rng.Left + cBorder, Top:=rng.Top + cBorder, Width:=rng.Width - 1, Height:=rng.Height - cBorder * 2)
        pic.Placement = xlMoveAndSize
    i = i + 12    '<---- Change the 12 to the same number as in the "Resize" line.
Next vPicture
Set pic = Nothing
End Sub

Hi

jolivanes thanks it works as it should. Have a nice day. Klaus W​