Import all images in a selected file instead of selected images only

Question

How can I change the linked macro to insert all images in a target folder instead of all selected images?

https://www.msofficeforums.com/drawing-and-graphics/49547-automate-insertion-multiple-images-into-document.html

I was able to use the above macro to insert multiple images, but instead of selecting them, I would like to simply select a target folder and have all images it contains inserted.

Answer 1

Please, test the next adapted code. It firstly places all files from a folder in an array and then processes its content:

Sub AddPicsWithCaption_FromFolder()
'Sourced from: https://www.msofficeforums.com/drawing-and-graphics/49547-automate-insertion-multiple-images-into-document.html
Application.ScreenUpdating = False
Dim Stl As Style, i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
ColWdth = PointsToCentimeters(TblWdth / NumCols)
ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0

'New part, to place in an array all files in a folder and then process that array content:____________
Dim strFoldPath As String, arrFiles, arrExt, strExt As String, n As Long
strFoldPath = "C:\Your folder where from to take pictures\" 'take care of ending backslash to not be missing
  
arrFiles = getAllFiles(strFoldPath)
'Debug.Print Join(arrFiles, vbCr): Stop 'just to see in Immediate Window all the collected files
'_____________________________________________________________________________________________________

If UBound(arrFiles) > -1 Then 'if more than a file was returned
   With ActiveDocument
      'Create a paragraph Style with 0 space before/after & centre-aligned
      On Error Resume Next
      Set Stl = .Styles("TblPic")
     If Stl Is Nothing Then Set Stl = .Styles.Add(Name:="TblPic", Type:=wdStyleTypeParagraph)
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    'Add a 2-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.width = ColWdth
      .Borders.Enable = True
    End With
    
    CaptionLabels.Add Name:="Picture"
    For i = 1 To UBound(arrFiles) + 1 Step NumCols 'iterate between the array elements with number of columns Step
      r = oTbl.Rows.count - 1
      
      arrExt = Split(arrFiles(i - 1), ".")
      strExt = "." & arrExt(UBound(arrExt)) 'extract file extension
      'If strExt = ".txt" Then Stop
      Select Case strExt
         Case ".gif", ".jpg", ".jpeg", ".bmp", ".tif", ".png" 'process only files with these extensions
              'Format the rows
              Call FormatRows(oTbl, r, RwHght)
              For c = 1 To NumCols
                j = j + 1: 'If j = 5 Then Stop
                'Insert the Picture
                Set iShp = ActiveDocument.InlineShapes.AddPicture( _
                  fileName:=arrFiles(j - 1 + n), LinkToFile:=False, _
                  SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
                With iShp
                  .LockAspectRatio = True
                  If (.width < ColWdth) And (.height < RwHght) Then
                    .width = ColWdth
                    If .height > RwHght Then .height = RwHght
                  End If
                End With
                'Get the Image name for the Caption
                StrTxt = Split(arrFiles(j - 1 + n), "\")(UBound(Split(arrFiles(j - 1 + n), "\")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                'Insert the Caption on the row below the picture
                With oTbl.Cell(r + 1, c).Range
                  .InsertBefore vbCr
                  .Characters.First.InsertCaption _
                  Label:="Picture", Title:=StrTxt, _
                  Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                  .Characters.First = vbNullString
                  .Characters.Last.Previous = vbNullString
                End With
                'Exit when we're done
                If j + n = UBound(arrFiles) + 1 Then Stop: Exit For
              Next c
              'Add extra rows as needed
              If (j + n) < UBound(arrFiles) + 1 Then
                oTbl.Rows.Add
                oTbl.Rows.Add
              End If
           Case Else: n = n + 1 'to also count files with no suitable extension...
        End Select
    Next i
 End If
ErrExit:
Application.ScreenUpdating = True
End Sub

Sub FormatRows(oTbl As table, x As Long, Hght As Single) 'existing, not modified at all...
 With oTbl
  With .Rows(x)
    .height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
 End With
End Sub

It also needs the next function to return the files array:

Private Function getAllFiles(strFold As String, Optional strExt As String = "*.*") As Variant
    getAllFiles = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir """ & strFold & _
                                              strExt & """ /b/s").StdOut.ReadAll, vbCrLf), "\")
End Function