Using VBA to insert images in a grid pattern

[prin1939]

I found this great, simple, code online that inserts images into a spreadsheet. The only problem is that the code inserts the images down a column or across a row. I'd like to insert images in a grid (2x2 or 3x3 per page for example) so that when I print it creates a nice report. I have hundreds of images to print and would like to save on paper. here's the code. Any ideas?

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = 1
If IsArray(PicList) Then
xRowIndex = 1
For lLoop = LBound(PicList) To UBound(PicList)
Set Rng = Cells(xRowIndex, xColIndex)
Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, 40, 30)
xRowIndex = xRowIndex + 1
Next
End If
End Sub

 

[Domenic]

Try something like this...

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit
[/COLOR]
[COLOR=darkblue]Sub[/COLOR] InsertPictures()
 
    [COLOR=darkblue]Dim[/COLOR] vFilename           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] oPic                [COLOR=darkblue]As[/COLOR] Picture
    [COLOR=darkblue]Dim[/COLOR] StartRow            [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] StartCol            [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] NumCols             [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] r                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] c                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    vFilename = Application.GetOpenFilename( _
        FileFilter:="Pictures (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select Picture", _
        MultiSelect:=True) [COLOR=green]'change the file filter accordingly[/COLOR]
        
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] IsArray(vFilename) [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    StartRow = 1 [COLOR=green]'change the start row accordingly[/COLOR]
    StartCol = 1 [COLOR=green]'change the start column accordingly[/COLOR]
    NumCols = 3 [COLOR=green]'change the number of columns accordingly[/COLOR]
    
    r = StartRow
    c = StartCol
    [COLOR=darkblue]For[/COLOR] i = [COLOR=darkblue]LBound[/COLOR](vFilename) [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](vFilename)
        [COLOR=darkblue]Set[/COLOR] oPic = ActiveSheet.Pictures.Insert(vFilename(i))
        [COLOR=darkblue]With[/COLOR] oPic
            .Left = Cells(r, c).Left
            .Top = Cells(r, c).Top
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        [COLOR=darkblue]If[/COLOR] i Mod NumCols = 0 [COLOR=darkblue]Then[/COLOR]
            r = r + 1
            c = StartCol
        [COLOR=darkblue]Else[/COLOR]
            c = c + 1
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] i
 
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

To insert the picture within the entire width and height of the cell, try replacing...

        [COLOR=darkblue]With[/COLOR] oPic
            .Left = Cells(r, c).Left
            .Top = Cells(r, c).Top
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]

with

        [COLOR=darkblue]With[/COLOR] oPic
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = Cells(r, c).Left
            .Top = Cells(r, c).Top
            .Width = Cells(r, c).Width
            .Height = Cells(r, c).Height
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]

Hope this helps!

 

[prin1939]

Perfect. Thank you very much. The last thing i would like to do is print the file name above or below each picture (similar to a caption). I haven't seen any code do that online yet.

 

[Domenic]

How about if we do it this way...

1. Insert a row of pictures in the first row specified.
2. Enter the labels for each picture in the row below.
3. Leave the next row blank.
4. Repeat Insert/Enter/Blank row

Would this meet your needs?

 

[prin1939]

Yes I think that would simplify the code a great deal and serve the same purpose.

 

[Domenic]

In the following code, you'll notice that in addition to making the changes as described I've added some formatting for rows containing the filename (ie. row height, bold, italic, etc). Change/delete these as desired.

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] InsertPictures()
 
    [COLOR=darkblue]Dim[/COLOR] vFilename           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] oPic                [COLOR=darkblue]As[/COLOR] Picture
    [COLOR=darkblue]Dim[/COLOR] StartRow            [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] StartCol            [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] NumCols             [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] r                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] c                   [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    vFilename = Application.GetOpenFilename( _
        FileFilter:="Pictures (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Select Picture", _
        MultiSelect:=True)
        
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] IsArray(vFilename) [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    StartRow = 1
    StartCol = 1
    NumCols = 3
    
    r = StartRow
    c = StartCol
    [COLOR=darkblue]For[/COLOR] i = [COLOR=darkblue]LBound[/COLOR](vFilename) [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](vFilename)
        [COLOR=darkblue]Set[/COLOR] oPic = ActiveSheet.Pictures.Insert(vFilename(i))
        [COLOR=darkblue]With[/COLOR] oPic
            .ShapeRange.LockAspectRatio = msoFalse
            .Left = Cells(r, c).Left
            .Top = Cells(r, c).Top
            .Width = Cells(r, c).Width
            .Height = Cells(r, c).Height
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        [COLOR=darkblue]With[/COLOR] Cells(r + 1, c)
            .RowHeight = 15
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .Font.Bold = [COLOR=darkblue]True[/COLOR]
            .Font.Italic = [COLOR=darkblue]True[/COLOR]
            .Value = oPic.Name
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        [COLOR=darkblue]If[/COLOR] i Mod NumCols = 0 [COLOR=darkblue]Then[/COLOR]
            r = r + 3
            c = StartCol
        [COLOR=darkblue]Else[/COLOR]
            c = c + 1
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] i
    
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
 
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Hope this helps!

 

[prin1939]

The code line that states .Value = oPic.Name returns the value "Picture 1" and counts up from there. Is there a way to display the actual file name? I changed the line to say .Value = vFileName but it displays the entire file path. I’d just like to see the file name.

 

[Domenic]

Try...

.Value = Mid(vFilename(i), InStrRev(vFilename(i), "\") + 1)

Hope this helps!

 

[grdc2003]

This is amazing!!! However I'm having trouble when inserting multiple aspect ratio pics (landscapes and portraits).
The landscapes go where specified but the portraits move somewhere else on the right side of the worksheet.
Any fix for this situation?
Thanks a lot in advance, as you already helped a lot.