Insert all images from a folder without selecting them

[YasserKhalil]

Hello everyone
I have the following code

Code: Select all

Sub Test()
    Dim picList(), picFormat As String, rng As Range, sShape As Shape, xColIndex As Integer, xRowIndex As Integer, lLoop As Integer
    On Error Resume Next
    picList = Application.GetOpenFilename(picFormat, MultiSelect:=True)
    xRowIndex = 1       'Row Number
    xColIndex = 2       'Column Number
    Application.ScreenUpdating = False
        If IsArray(picList) Then
            For lLoop = LBound(picList) To UBound(picList)
                Set rng = Cells(xRowIndex, xColIndex)
                Set sShape = ActiveSheet.Shapes.AddPicture(picList(lLoop), msoFalse, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height)
                rng.Offset(, -1).Value = Split(Split(picList(lLoop), "\")(UBound(Split(picList(lLoop), "\"))), ".")(0)
                xRowIndex = xRowIndex + 1
            Next lLoop
        End If
    Application.ScreenUpdating = True
End Sub

The code enables the user to select a folder then to select the images .. How can I avoid selecting the images point (I mean to select only the folder then to insert all the images with any extension within that folder?)

[HansV]

You can use Application.FileDialog(msoFileDialogFolderPicker) to let the user select a folder.
You can then use the Dir function to loop through the files in the selected folder.

[YasserKhalil]

Thanks a lot. But there is no way in this line to select all the files (I mean implemented feature of GetOpenFilename)

Code: Select all

picList = Application.GetOpenFilename(picFormat, MultiSelect:=True)

[HansV]

No. The user would have to select all the files, for example by pressing Ctrl+A.

[YasserKhalil]

I have followed your instructions and here's the final code for review

Code: Select all

Sub Test()
    Dim vExt, ws As Worksheet, cPic As Range, sFolderPath As String, sFile As String
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set cPic = ws.Range("B2")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show Then sFolderPath = .SelectedItems(1) & "\"
    End With
    If sFolderPath = "" Then Exit Sub
    Application.ScreenUpdating = False
        For Each vExt In Array("*.jpg", "*.jpeg", "*.png")
            sFile = Dir(sFolderPath & vExt)
            Do While Len(sFile) > 0
                cPic.Offset(, -1).Value = Split(sFile, ".")(0)
                With ws.Shapes.AddPicture(Filename:=sFolderPath & sFile, _
                    LinkToFile:=False, SaveWithDocument:=True, _
                    Left:=cPic.Left, Top:=cPic.Top, _
                    Width:=cPic.Width, Height:=cPic.Height)
                End With
                Set cPic = cPic.Offset(1)
                sFile = Dir
            Loop
        Next vExt
    Application.ScreenUpdating = True
End Sub

Question: is it possible to sort a range that has a column of images?

[HansV]

Change

Code: Select all

                With ws.Shapes.AddPicture(Filename:=sFolderPath & sFile, _
                    LinkToFile:=False, SaveWithDocument:=True, _
                    Left:=cPic.Left, Top:=cPic.Top, _
                    Width:=cPic.Width, Height:=cPic.Height)
                End With

to

Code: Select all

                With ws.Shapes.AddPicture(Filename:=sFolderPath & sFile, _
                    LinkToFile:=False, SaveWithDocument:=True, _
                    Left:=cPic.Left, Top:=cPic.Top, _
                    Width:=cPic.Width, Height:=cPic.Height)
                        .Placement = xlMove ' or xlMoveAndSize
                End With

The pictures should then move with the cells they're in when you sort the range.

[YasserKhalil]

Thank you very much my tutor
When sorting the range manually, it works well with no problems and the images moved to correct positions. But when I recorded a macro to the sort process like that

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'

'
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("C2:C8") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:D8")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

the macro doesn't return the same result as the manual steps. Any ideas?

[HansV]

How should I know? I haven't seen the workbook.

[YasserKhalil]

The workbook depends on another open workbook to get some data from.
The idea of the code (first step is to get the name of the image in column A and the image in column B) and this is done by he code perfectly now.
The second step is to get some details from another workbook by the first column data and put the results in columns C and D.
The thrd step I am stuck at is to sort the data by column C (this works when I sort the range manually) but doesn't work if I used the same recorded macro.

[YasserKhalil]

Here's a sample workbook to try the code on

[HansV]

The shapes (pictures) must fit entirely within the cells. Run the following macro to achieve this:

Code: Select all

Sub ResizeShapes()
    Dim shp As Shape
    Dim rng As Range
    For Each shp In ActiveSheet.Shapes
        Set rng = shp.TopLeftCell
        shp.Top = rng.Top + 1
        shp.Left = rng.Left + 1
        shp.Height = rng.Height - 2
        shp.Width = rng.Width - 2
    Next shp
End Sub

Sorting should then work. Here is a simplified version:

Code: Select all

Sub SortRange()
    Range("A1:D8").Sort Key1:=Range("C1"), Header:=xlYes
End Sub

[YasserKhalil]

Amazing. This works like charm. Thank you very much for the great assistance, my tutor.