Open directory for multiple times to import photos

[jaelh]

Hello,

I am using the following VBA code in order to insert multiple pictures from a folder in specific cells then resize it and it is working perfect.

The folder path is already mentioned in the code. So if I want to import photos from another folders (one after the other, not the same time), I have to open the code and change the folder path.
Unfortunately, there is no option in the code to open a directory and select the folder I need .. then run the code again and select another folder and so on ..

How can I do this, so when running the code I would be able to:

1- select the folder I want to import the photos from ..
2- repeat the same procedure with another folder

Kindly be aware to change the folder directory while checking the code

Thanks in advance

Regards

Sub AddOlEObject25()
Dim mainWorkBook As Workbook
Dim fdl As FileDialog

Set mainWorkBook = ActiveWorkbook
Sheets("Sheet1").Activate
Folderpath = "C:\Users\***\Downloads"  'change folder path here
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 + 50
 
 Sheets("Sheet1").Range("A" & counter).ColumnWidth = 10
 Sheets("Sheet1").Range("A" & counter).RowHeight = 15
 Sheets("Sheet1").Range("A" & counter).Activate
 Call insert(strCompFilePath, counter)
 Sheets("Sheet1").Activate
 End If
End If
Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
 .LockAspectRatio = msoFalse
 .Width = 465
 
 .Height = 450
End With
.Left = ActiveSheet.Range("A" & counter).Left
.Top = ActiveSheet.Range("A" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function

 

[Micron]

Not sure if this would do what you want, but if you use the msoFileDialogFolder picker, it will open a dialog similar to Windows File Explorer. When you pick the folder and click the dialog button, it returns the folder path and you use that value. You don't hard code the path as you are doing. That option is still a manual operation, which I can't tell whether or not it is what you want. #2 could mean you want some sort of loop to automatically choose folders without you doing anything else.