import multiple photos from a folders then resize

[jaelh]

I am using the following code to insert 1 image from a specific folder into a selected cell then resize it.

Please could you help me in the following:

1- select multiple folders to import the photos from each instead of 1 folder

2- resize each photo inserted into a range of cells for example (A4:B10)

for example

Photo 1 ... (A4:B10)

photo 2 ... (C4:D10)

Photo 3 .. (E4:F10)

and so on

Thanks in advance

Sub InsertPicAndResizeToCell()

Dim vPics
Dim iPic As Integer
vPics = Application.GetOpenFilename("All image files (*.JPG;*.BMP;*.PNG),*.JPG;*.BMP", MultiSelect:=True)
If TypeName(vPics) = "Boolean" Then Exit Sub ' cancelled

Dim oNewPic As Shape
Dim Pic1 As Range

'cell or range of cells where the picture should be inserted:
Set Pic1 = ActiveWindow.RangeSelection

For iPic = LBound(vPics) To UBound(vPics)

  'Insert the picture:
  Set oNewPic = ActiveSheet.Shapes.AddPicture(Filename:=vPics(iPic), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
  Left:=Pic1.Left + 0, Top:=Pic1.Top + 0, Width:=Pic1.Height, Height:=Pic1.Height)

  'Maintain original aspect ratio and set to full size
  oNewPic.LockAspectRatio = msoTrue
  oNewPic.ScaleHeight factor:=1, RelativeToOriginalSize:=msoTrue
  oNewPic.ScaleWidth factor:=1, RelativeToOriginalSize:=msoTrue

  '    'Resize the picture to fit in the destination cells
  If (oNewPic.Width / oNewPic.Height) < (Pic1.Width / Pic1.Height) Then
  oNewPic.Width = Pic1.Width + 0
Else:  oNewPic.Height = Pic1.Height - 1000
  
  End If
  Set Pic1 = Pic1.Offset(1)  ' replace Sheet1.ComboBox1 with reference to your combobox
Next


End Sub

 

[John_w]

Try this macro:

Option Explicit

Public Sub Insert_Images_from_Folders()

    Dim folders() As String, foldersCount As Long
    Dim showOK As Boolean
    Dim fileName As String
    Dim i As Long
    Dim pic As Shape
    Dim picRange As Range
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        foldersCount = 0
        Do
            .Title = "Select images folder " & foldersCount + 1 & " or click Cancel to " & IIf(foldersCount = 0, "exit macro", "insert images")
            showOK = .Show
            If showOK Then
                ReDim Preserve folders(0 To foldersCount)
                folders(foldersCount) = .SelectedItems(1) & "\"
                foldersCount = foldersCount + 1
            End If
        Loop Until Not showOK
    End With
    If foldersCount = 0 Then Exit Sub
    
    Set picRange = ActiveSheet.Range("A4:B10")
    
    For i = 0 To UBound(folders)
        fileName = Dir(folders(i) & "*.*")
        While fileName <> vbNullString
            If InStr(1, "|.jpg|.png.|.bmp|", "|" & Mid(fileName, InStrRev(fileName, ".")) & "|", vbTextCompare) Then
                With picRange
                    Set pic = .Worksheet.Shapes.AddPicture(fileName:=folders(i) & fileName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                           Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
                    Set picRange = .Offset(, .Columns.Count)
                End With
            End If
            fileName = Dir
        Wend
    Next
    
End Sub

 

[jaelh]

Try this macro:

Option Explicit

Public Sub Insert_Images_from_Folders()

    Dim folders() As String, foldersCount As Long
    Dim showOK As Boolean
    Dim fileName As String
    Dim i As Long
    Dim pic As Shape
    Dim picRange As Range
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        foldersCount = 0
        Do
            .Title = "Select images folder " & foldersCount + 1 & " or click Cancel to " & IIf(foldersCount = 0, "exit macro", "insert images")
            showOK = .Show
            If showOK Then
                ReDim Preserve folders(0 To foldersCount)
                folders(foldersCount) = .SelectedItems(1) & "\"
                foldersCount = foldersCount + 1
            End If
        Loop Until Not showOK
    End With
    If foldersCount = 0 Then Exit Sub
   
    Set picRange = ActiveSheet.Range("A4:B10")
   
    For i = 0 To UBound(folders)
        fileName = Dir(folders(i) & "*.*")
        While fileName <> vbNullString
            If InStr(1, "|.jpg|.png.|.bmp|", "|" & Mid(fileName, InStrRev(fileName, ".")) & "|", vbTextCompare) Then
                With picRange
                    Set pic = .Worksheet.Shapes.AddPicture(fileName:=folders(i) & fileName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                           Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
                    Set picRange = .Offset(, .Columns.Count)
                End With
            End If
            fileName = Dir
        Wend
    Next
   
End Sub

Thank you, unfortunately the code always opens the file dialog and nothing else

 

[John_w]

Look at the title of the folder picker. You are meant to select one folder and click OK each time the folder picker is displayed, and when all the folders have been selected click Cancel to insert the images from the selected folder(s). If you click Cancel the first time the folder picker is displayed, thus not selecting a folder, the macro will exit.