Insert Multiple Photos at Once Multiple Cells

[Susanto3311]

hi expert..

this macro code below working properly to insert picture from a folder with one by one select picture
i want to modified so macro work with criteria:
1. can insert picture from a folder with multiple select picture and insert to multiple cell at once
2. pictures can inserted automatically consecutive/sequentially placing into target cell (target cell are random) with name of file picture are random (main option)
3. if point 2 impossible to do it , to insert automatically consecutive can use name of file picture or based on name pictures like e.g. photo1, photo2,photo3, photo4,
or whatever name's file picture etc....(secondary option)

the code into my attachment file i can' show this board, i don't know why.
any help, greatly appreciated..
susanto

[HansV]

Try this:

Code: Select all

Sub InsertPicture()
    Const cBorder = 2
    Dim vArray As Variant, vPicture As Variant, pic As Shape, i As Long, rng As Range
    vArray = Application.GetOpenFilename(FileFilter:="Pictures (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.jpg; *.jpeg; *.tif", _
        Title:="Select Picture to Import", MultiSelect:=True)
    If vArray = False Then Exit Sub
    i = 1
    For Each vPicture In vArray
        i = i + 2
        Set rng = Cells(16, i)
        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       ' << change as required
            .Width = rng.Width - (2 * cBorder)
            .Height = rng.Height - (2 * cBorder)
            .Placement = xlMoveAndSize
        End With
        rng.Offset(0, 1).Value = vPicture
    Next vPicture
    Set pic = Nothing
End Sub

[Susanto3311]

hi HansV, thank you but still not work show message "Run -Time Error 13, Type Mismatch"

[HansV]

Sorry about that. Change the line

Code: Select all

   If vArray = False Then Exit Sub

to

Code: Select all

    If Not IsArray(vArray) Then Exit Sub

[Susanto3311]

hi ..
still found problem:
1. the code can't work for merge cell target e.g in cell C16 merge with cell C17, E16 with F16, G16 with H16. I want the code work too if cell are merged
2. the name of files included imported should be not imported.

[HansV]

Here is a new version:

Code: Select all

Sub InsertPicture()
    Const cBorder = 2
    Dim vArray As Variant, vPicture As Variant, pic As Shape, i As Long, rng As Range
    vArray = Application.GetOpenFilename(FileFilter:="Pictures (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.jpg; *.jpeg; *.tif", _
        Title:="Select Picture to Import", MultiSelect:=True)
    If Not IsArray(vArray) Then Exit Sub
    i = 1
    For Each vPicture In vArray
        i = i + 2
        Set rng = Cells(16, i).MergeArea
        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
    Next vPicture
    Set pic = Nothing
End Sub

[Susanto3311]

hi Hans, working well like my expected result
thank you very much!!!

[Susanto3311]

hi.. HansV

this code working well in only cell/rows 16...
how to modified that code work in any where cell i mean like D3 till D6 or J8 till J11 or any where cell but keep retains in same line/rows

Code: Select all

Sub InsertPicture()
    Const cBorder = 2
    Dim vArray As Variant, vPicture As Variant, pic As Shape, i As Long, rng As Range
    vArray = Application.GetOpenFilename(FileFilter:="Pictures (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.jpg; *.jpeg; *.tif", _
        Title:="Select Picture to Import", MultiSelect:=True)
    If Not IsArray(vArray) Then Exit Sub
    i = 1
    For Each vPicture In vArray
        i = i + 2
        Set rng = Cells(16, i).MergeArea
        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
    Next vPicture
    Set pic = Nothing
End Sub

[HansV]

I don't understand what you mean by "D3 till D6 or J8 till J11 or any where cell but keep retains in same line/rows". Can you explain? Thanks in advance.

[Susanto3311]

hi..
your code "Set rng = Cells(16, i).MergeArea" work in rows 16..
i want the picture can insert into dynamic cell (any cell)
my target to insert photos, sometime in cell like e.g. D3,D4,D5,D6 (if my 4 photos).
the core i want the new code can insert photo into dynamic cell.

[HansV]

See the attached workbook.

InsertPic.xlsm

[Susanto3311]

hi Hans, thank you so much
Beautiful finishing.
Hans, i can't see your code..
where is? cause i want to make add-ins (personal add-ins)

[HansV]

Sorry, I didn't see that you edited your last reply. In general, it is better to post a new reply - I will always notice that.
Press Alt+F11 to activate the Visual Basic Editor.

S1166.png

Module1 only contains a macro that displays the userform:

Code: Select all

Sub Showform()
    UserForm1.Show
End Sub

The command button on the worksheet calls this macro.

The rest of the code is in the module of the userform.
Double-click the userform to open it, then click the 'View Code' button to see the code.

S1167.png

Code: Select all

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 (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.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(0, 1)
        Else
            Set rng = rng.Offset(1, 0)
        End If
    Next vPicture
    Set pic = Nothing
    Unload Me
End Sub