Sub Add_PicsinTable_with_Captions()
Application.ScreenUpdating = False
Dim 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, RowHght As Single, ColWdth As Single
Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single
HPad = CentimetersToPoints(0#):     VPad = CentimetersToPoints(0#)
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RowHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?")))
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
PicHght = RowHght - VPad * 2: PicWdth = ColWdth - HPad * 2
'MsgBox "PicWdth: " & PointsToCentimeters(PicWdth) & vbTab & "ColWdth: " & PointsToCentimeters(ColWdth)
'MsgBox "PicHght: " & PointsToCentimeters(PicHght) & vbTab & "RowHght: " & PointsToCentimeters(RowHght)
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
    'Create a paragraph Style with 0 space before/after & centre-aligned
    On Error Resume Next
    With ActiveDocument
      .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
      .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
    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 ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = VPad
      .BottomPadding = VPad
      .LeftPadding = HPad
      .RightPadding = HPad
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    CaptionLabels.Add Name:="Picture"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = ((i - 1) / NumCols + 1) * 2 - 1
      'Format the rows
      Call FormatRows(oTbl, r, RowHght)
      For c = 1 To NumCols
        j = j + 1
        'Insert the Picture
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
        With iShp
          .LockAspectRatio = True
          If .Width < PicWdth Then .Width = PicWdth
          If .Height > PicHght Then .Height = PicHght
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = Split(Split(StrTxt, "")(UBound(Split(StrTxt, ""))), ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          With .Range
            .Text = StrTxt
                 End With
        End With
        'Exit when we're done
        If j = .SelectedItems.Count Then Exit For
      Next
      'Add extra rows as needed
      If j < .SelectedItems.Count Then
        oTbl.Rows.Add
        oTbl.Rows.Add
      End If
    Next
  Else
  End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0#)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub