Create macro to insert photos into Excel grid

larchfield

New Member
Joined
Oct 27, 2015
Messages
2
Hi, wonder if anyone could help here?

I need to create a macro that can go and fetch photos from a specified folder and insert them in a grid pattern into a worksheet. I have no idea where to start, apart from a few bits of code I've found on this forum to go and fetch 1 photo to insert.

The grid would ideally be 3 columns across by an unlimited number of rows, dependent on the number of photos in the specified folder.

In the cell directly below each photo there would be an empty cell for a caption.

There would be a column spacer between each of the 3 photo columns, and a row spacer between each caption cell and photo cell.

Hope this is clear enough as I couldn't insert an image here?

Thanks
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

Perpa

Well-known Member
Joined
Dec 18, 2012
Messages
635
Hi, wonder if anyone could help here?

I need to create a macro that can go and fetch photos from a specified folder and insert them in a grid pattern into a worksheet. I have no idea where to start, apart from a few bits of code I've found on this forum to go and fetch 1 photo to insert.

The grid would ideally be 3 columns across by an unlimited number of rows, dependent on the number of photos in the specified folder.

In the cell directly below each photo there would be an empty cell for a caption.

There would be a column spacer between each of the 3 photo columns, and a row spacer between each caption cell and photo cell.

Hope this is clear enough as I couldn't insert an image here?

Thanks


larchfield,
See if the following links will help you get going...

http://www.mrexcel.com/forum/excel-questions/895744-[photo-comment]-problem-local-file-only.html

Excel-VBA : Insert Multiple Images from a Folder to Excel Cells


Perpa
 

larchfield

New Member
Joined
Oct 27, 2015
Messages
2

Thanks, Perpa. Appreciate the prompt reply!

A couple of key points I should've mentioned:
- the folder containing photos will vary each time this macro is run
- I need to be able to select a folder, not a file, or a selection of files - but grab everything from a specified folder.

I seem to be able to find bits of code that are really useful for doing certain elements of the solution I'm after, separately. The rub is combining them it seems! Struggling with that bit...

The grid pattern with photos sized as per cell sizes, and the repeating row loop (3 photos across, x down) are the bits I seem to be having trouble with.

Regards
 

Perpa

Well-known Member
Joined
Dec 18, 2012
Messages
635
Thanks, Perpa. Appreciate the prompt reply!

A couple of key points I should've mentioned:
- the folder containing photos will vary each time this macro is run
- I need to be able to select a folder, not a file, or a selection of files - but grab everything from a specified folder.

I seem to be able to find bits of code that are really useful for doing certain elements of the solution I'm after, separately. The rub is combining them it seems! Struggling with that bit...

The grid pattern with photos sized as per cell sizes, and the repeating row loop (3 photos across, x down) are the bits I seem to be having trouble with.

Regards


larchfield,
I modified the code I pointed you to in my earlier post. This modified code provides an INPUTBOX
that enables you to change the Folderpath to pictures you want to load and to '...grab everything
from a specified folder'...as you wanted.

The filename is placed in the cell below each Picture. You can change that to a different caption if
you want.

You end up with 3 columns of pictures, annotated below each picture cell, with a blank
column in between groups of pictures, and a blank row between the next picture and the caption above.
I think that is what you were trying to get to. Give it a try and let me know how it goes.
Perpa

Code:
Sub AddOlEObject1()

    Dim mainWorkBook As Workbook
    Application.ScreenUpdating = False
    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate    'Change the sheet name from "Sheet1" to the sheet name where you want your pictures to go
    
    'Cleanoff Sheet1
    ActiveSheet.UsedRange.ClearContents
    For Each sh In Sheets("Sheet1").Shapes
       sh.Delete
    Next sh
    'Change the folderpath to wherever your pictures are coming from

    Folderpath = InputBox("Enter the complete folder path to you files" & Chr(13) & " in this format: 'C:\Users\you\folder1'")

    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then

                counter = counter + 1
                
                If counter <= NoOfFiles / 3 Then
                    If counter = 1 Then counter1 = 1
                    If counter > 1 Then counter1 = counter1 + 3
                    Sheets("Sheet1").Range("B" & counter1 + 1).Value = fls.Name
                    Sheets("Sheet1").Range("B" & counter1).ColumnWidth = 27     'Adjust COLUMNS to fit your pictures
                    Sheets("Sheet1").Range("B" & counter1).RowHeight = 80           'Adjust ROWS to fit your pictures
                    Sheets("Sheet1").Range("B" & counter1).Activate
                    Call insert1(strCompFilePath, counter1)
                    Sheets("Sheet1").Activate
                End If

                If counter > NoOfFiles / 3 And counter <= NoOfFiles * 2 / 3 Then
                    counter2 = counter - Application.Round(NoOfFiles / 3, 0)
                    If counter2 > 1 Then counter2 = 3 * counter2 - 2
                    Sheets("Sheet1").Range("D" & counter2 + 1).Value = fls.Name
                    Sheets("Sheet1").Range("D" & counter2).ColumnWidth = 27     'Adjust COLUMNS to fit your pictures
                    Sheets("Sheet1").Range("D" & counter2).RowHeight = 80           'Adjust ROWS to fit your pictures
                    Sheets("Sheet1").Range("D" & counter2).Activate
                    Call insert2(strCompFilePath, counter2)
                    Sheets("Sheet1").Activate
                End If

                If counter > NoOfFiles * 2 / 3 Then
                    counter3 = counter - Application.Round(NoOfFiles * 2 / 3, 0)
                    If counter3 > 1 Then counter3 = 3 * counter3 - 2
                    Sheets("Sheet1").Range("F" & counter3 + 1).Value = fls.Name
                    Sheets("Sheet1").Range("F" & counter3).ColumnWidth = 27     'Adjust COLUMNS to fit your pictures
                    Sheets("Sheet1").Range("F" & counter3).RowHeight = 80           'Adjust ROWS to fit your pictures
                    Sheets("Sheet1").Range("F" & counter3).Activate
                    Call insert3(strCompFilePath, counter3)
                    Sheets("Sheet1").Activate
                End If
                
            End If
        End If
    Next
'mainWorkBook.Save
Application.ScreenUpdating = True
End Sub

Function insert1(PicPath, counter1)

    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            '.Width = 50      'Adjust to change the WIDTH of your pictures
            .Height = 80     'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("B" & counter1).Left
        .Top = ActiveSheet.Range("B" & counter1).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Function insert2(PicPath, counter2)

    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            '.Width = 50      'Adjust to change the WIDTH of your pictures
            .Height = 80     'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("D" & counter2).Left
        .Top = ActiveSheet.Range("D" & counter2).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function
Function insert3(PicPath, counter3)

    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            '.Width = 50      'Adjust to change the WIDTH of your pictures
            .Height = 80     'Adjust to change the HEIGHT of your pictures
        End With
        .Left = ActiveSheet.Range("F" & counter3).Left
        .Top = ActiveSheet.Range("F" & counter3).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Sub ClrSheetofStuff()
    Sheets("Sheet1").Activate    'Change the sheet name from "Sheet1" to the sheet name you want to clear
    ActiveSheet.UsedRange.ClearContents
    For Each sh In Sheets("Sheet1").Shapes
       sh.Delete
    Next sh
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,132,902
Messages
5,655,884
Members
418,249
Latest member
JOYADA

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top