Sub InsertImagesInColumnG_Ver2()

Dim folderPath As String

Dim imgRow As Long

Dim ws As Worksheet

Dim fd As FileDialog

Dim topPosition As Double

Dim firstImageRow As Long ' To track the row of the first imported image

Dim firstPicture As Shape ' To track the first imported image

' Set the worksheet where images will be inserted

Set ws = ThisWorkbook.Sheets("Sheet1")

' Close the UserForm if it is already open

CloseUserFormIfOpen

' Delete existing images but exclude shapes with Rounded Corners

Dim picture As Shape

For Each picture In ws.Shapes

If picture.AutoShapeType <> msoShapeRoundedRectangle Then

picture.Delete

End If

Next picture

' Clear values in column I:K and reset headers

' ws.Columns("I").ClearContents

ws.Columns("I:M").ClearContents

ws.Cells(4, 7).Value = "Image" ' Header for images in column G

ws.Cells(4, 9).Value = "Filename" ' Header for filenames in column I

ws.Rows(4).Font.Bold = True ' Make headers bold

' Set column width for column G

ws.Columns("G").ColumnWidth = 12.14

' Set column width for column I and enable wrap text

ws.Columns("I").ColumnWidth = 50 ' Set width to 50

ws.Columns("I").WrapText = True

' Open a dialog box to select the folder

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

With fd

.Title = "Select Folder Containing Images"

.AllowMultiSelect = False

If .Show = -1 Then ' If the user selects a folder

folderPath = .SelectedItems(1)

Else

MsgBox "No folder selected. Operation canceled.", vbExclamation

Exit Sub

End If

End With

' Ensure the folder path ends with a backslash

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

' Initialize the starting position

imgRow = 5

topPosition = ws.Cells(imgRow, 7).Top ' Starting position in column G

firstImageRow = 0 ' Initialize to ensure we track the first image row

' Recursively search for image files in the folder and subfolders

Call ImportImagesFromFolder(ws, folderPath, imgRow, topPosition, firstImageRow, firstPicture)

' Set the row height of the first imported image to 66

If firstImageRow > 0 Then

ws.Rows(firstImageRow).RowHeight = 66

End If

' Move the first picture 0.5 points down

If Not firstPicture Is Nothing Then

firstPicture.Top = firstPicture.Top + 0.5

End If

' Notify the user

MsgBox "Headers added. Column I set to 50 width with text wrapping. All images and file paths have been inserted in column G and I.", vbInformation

End Sub

Sub ImportImagesFromFolder(ws As Worksheet, folderPath As String, ByRef imgRow As Long, ByRef topPosition As Double, ByRef firstImageRow As Long, ByRef firstPicture As Shape)

Dim Filename As String

Dim subFolder As Object

Dim fso As Object

Dim folder As Object

Dim subFolders As Object

Dim picture As Shape

' File System Object for traversing directories

Set fso = CreateObject("Scripting.FileSystemObject")

Set folder = fso.GetFolder(folderPath)

Set subFolders = folder.subFolders

' Loop through all image files in the current folder

Filename = Dir(folderPath & "*.*")

Do While Filename <> ""

' Check if the file is an image

If LCase(Filename) Like "*.jpg" Or LCase(Filename) Like "*.jpeg" Or LCase(Filename) Like "*.png" Or LCase(Filename) Like "*.bmp" Or LCase(Filename) Like "*.gif" Then

' Insert the image into the worksheet as a Shape object

Set picture = ws.Shapes.AddPicture(folderPath & Filename, _

msoFalse, msoCTrue, _

ws.Cells(imgRow, 7).Left, _

topPosition, _

64, 64)

' Move the image 1.2 pixels to the right

picture.Left = picture.Left + 1.2

' Track the first imported image and its row

If firstImageRow = 0 Then

firstImageRow = imgRow

Set firstPicture = picture

End If

' Set row height to 64.5 for the current row

ws.Rows(imgRow).RowHeight = 64.5

' Add the full file path in column I

ws.Cells(imgRow, 9).Value = folderPath & Filename

' Center the filename height-wise in column I

ws.Cells(imgRow, 9).VerticalAlignment = xlCenter

' Move the top position down for the next image

topPosition = topPosition + 64 + 0.5 ' Add a 0.5-pixel gap between images

' Increment the row for the next image

imgRow = imgRow + 1

End If

' Get the next file in the folder

Filename = Dir

Loop

' Recursively process subfolders

For Each subFolder In subFolders

Call ImportImagesFromFolder(ws, subFolder.Path & "\", imgRow, topPosition, firstImageRow, firstPicture)

Next subFolder

End Sub