Insert multiple images from multiple folders in VBA

Question

Dears,

Would you be so kind and help me with the modification of the script below? I would like to add the function that will allow me to choose a folder manually (with Application.FileDialog(msoFileDialogFolderPicker function I guess)

Also, it would be great if the code will allow me to choose where the images will be added directly from the excel (for example by a msg box or only based on the active cell)

Description of the current code: Macro allows insert images according to the names from defined folder.

Goal: Insert a lot of images from a lot of folders with a different paths.

Sub AddPictures()
Dim cel As Range, Pictures As Range, PictureFileNames As Range, targ As Range
Dim j As Long, n As Long
Dim flPath As String, flName As String
Dim shp As Shape

flPath = "C:\Temp\"                   'Path to pictures


With ActiveSheet
    Set Pictures = .Range("B2")             'First picture goes here
    Set PictureFileNames = .Range("A2")     'First picture file name found here
    Set PictureFileNames = Range(PictureFileNames, .Cells(.Rows.Count, PictureFileNames.Column).End(xlUp))   'All picture file names in this column
    n = Application.CountA(PictureFileNames)
    If n = 0 Then Exit Sub
    
        'Delete existing pictures
    For Each shp In .Shapes
        If shp.Type = msoPicture Then
            If shp.TopLeftCell.Row = Pictures.Row Then shp.Delete
        End If
    Next
    
        'Add new pictures, resized to fit the cell
    For Each cel In PictureFileNames
        If cel.Value <> "" Then
            j = j + 1
            Set targ = Pictures.Cells(j, 1)
            Set shp = .Shapes.AddPicture(Filename:=flPath & cel.Value, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
                Left:=targ.Left, Top:=targ.Top, Width:=targ.Width, Height:=targ.RowHeight)
            shp.Name = "pic" & cel.Value
        End If
    Next

 End With
 
End Sub

Thank you very much for support.

Answer 1

Try, Column A is Folder name, Column B is File name, Column C is Picture.

• Check Reference Microsoft Scripting Runtime

Option Explicit

Sub GetFileFromFolder()
    Dim n           As Long
    Dim fd As FileDialog
    Dim strFolder As String
    Dim colResult As Collection
    Dim i As Long, k As Long, z As Long
    Dim vSplit
    Dim strFn As String
    Dim vR() As String
    Dim p As String, c As String
    Dim rngDB As Range, rng As Range
    Dim Ws As Worksheet
    
    Set Ws = ActiveSheet
    Set rngDB = Ws.UsedRange.Columns("a:b")
    
    Ws.Pictures.Delete
    rngDB.Value = Empty

    p = Application.PathSeparator
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Show
        .InitialView = msoFileDialogViewList
        .Title = "Select the Folder "
        .AllowMultiSelect = False
        
        If .SelectedItems.Count = 0 Then
        Else
            strFolder = .SelectedItems(1)
            Set colResult = SearchFolder(strFolder)
            
            i = colResult.Count
            Application.ScreenUpdating = False
            ReDim vR(1 To i, 1 To 7)
            For k = 1 To i
                c = colResult(k)
                If isExtend(c) Then
                    vSplit = Split(colResult(k), p)
                    strFn = vSplit(UBound(vSplit))
                    vR(k, 2) = Left(colResult(k), Len(colResult(k)) - Len(strFn) - 1) 'Folder name
                    vR(k, 3) = strFn        'File name with extension
                    vR(k, 4) = Split(strFn, ".")(0) 'File name without extension

                    z = z + 1
                    GetPicture c, Range("c" & z)    'Picture
                    Range("a" & z) = vR(k, 2)       'Foledr name
                    Range("b" & z) = vR(k, 3)       'File name without extension
                End If
            Next k
            Application.ScreenUpdating = True
        End If
    End With
End Sub
Function SearchFolder(strRoot As String)
    Dim FS As Scripting.FileSystemObject
    Dim fsFD As Folder
    Dim f As File
    Dim colFile As Collection
    Dim p As String
    
    On Error Resume Next
    p = Application.PathSeparator
    If Right(strRoot, 1) = p Then
    Else
        strRoot = strRoot & p
    End If
    Set FS = New Scripting.FileSystemObject
    Set fsFD = FS.GetFolder(strRoot)
    Set colFile = New Collection
    For Each f In fsFD.Files
        colFile.Add f.Path
    Next f
        
    SearchSubfolder colFile, fsFD

    
    Set SearchFolder = colFile
    Set fsFD = Nothing
    Set FS = Nothing
    Set colFile = Nothing

End Function
Sub SearchSubfolder(colFile As Collection, objFolder As Folder)
    Dim sbFolder As Object
    Dim f As Object
    For Each sbFolder In objFolder.subfolders
        SearchSubfolder colFile, sbFolder
        For Each f In sbFolder.Files
            colFile.Add f.Path
        Next f
    Next sbFolder

End Sub

Function isExtend(str As String) As Boolean
    Dim vExtend, v
    isExtend = False
    vExtend = Split("*.emf,*.wmf,*.jpg,*.jpeg,*.jfif,*.jpe,*.png,*.bmp,*.dib,*.gif,*.emz,*.wmz,*.pcz,*.tif,*.tiff,*.cgm,*.eps,*.pct,*.pict,*.wpg", ",")
    For Each v In vExtend
        If LCase(str) Like v Then
            isExtend = True
            Exit For
        End If
    Next v
   
End Function
Sub GetPicture(strPic As String, rngPic As Range)
    Dim Pic As Picture
    Dim shp As Shape
    Dim l As Single, t As Single, w As Single, h As Single

    With rngPic.MergeArea
        t = .Top
        l = .Left
        w = .Width
        h = .Height
        Set shp = ActiveSheet.Shapes.AddPicture(strPic, msoCTrue, msoCTrue, l, t, w, h)
     End With
End Sub