Create macro to insert photos into Excel grid

[larchfield]

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

 

[Perpa]

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]

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

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]

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

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