Create macro to insert photos into Excel grid

Thanks Thanks:  0
Likes Likes:  0
Results 1 to 4 of 4

Thread: Create macro to insert photos into Excel grid

  1. #1
    New Member
    Join Date
    Oct 2015
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Create macro to insert photos into Excel grid

     
    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

  2. #2
    Board Regular
    Join Date
    Dec 2012
    Location
    SoCal
    Posts
    512
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create macro to insert photos into Excel grid

    Quote Originally Posted by larchfield View Post
    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-q...file-only.html

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


    Perpa

  3. #3
    New Member
    Join Date
    Oct 2015
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create macro to insert photos into Excel grid

    Quote Originally Posted by Perpa View Post
    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

  4. #4
    Board Regular
    Join Date
    Dec 2012
    Location
    SoCal
    Posts
    512
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create macro to insert photos into Excel grid

      
    Quote Originally Posted by larchfield View Post
    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

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

 
DMCA.com