Sub AddCaptionedImages()
'
' Inserts a 1 column x 4 row/page table into a page, with an image in the first row and a caption in the second row
'
'Graham Mayor - http://www.gmayor.com - Last updated - 24 Sep 2018

Dim oTbl As Table, i As Long, j As Long, StrTxt As String
Dim fd As Object
Dim bHyphen As Boolean
Dim strTitle As String

    Application.ScreenUpdating = False
    Set fd = Application.FileDialog(3)
    'Select and insert the Pics
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        If .Show = -1 Then
            If MsgBox("Include hyphen at end of caption?", vbYesNo) = vbYes Then bHyphen = True
            If bHyphen = True Then
                strTitle = " - "
            Else
                strTitle = ""
            End If
            'Add a 2-row by 1-column table with 7cm column width to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(15.98)
                'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Photograph"
            For i = 1 To .SelectedItems.Count
                j = i * 2 - 1
                'Add extra rows as needed
                If j > oTbl.Rows.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    Call FormatRows(oTbl, j)
                End If
                'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _
                        FileName:=.SelectedItems(i), LinkToFile:=False, _
                        SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(1).Range
                'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "\")(UBound(Split(.SelectedItems(i), "\")))
                StrTxt = ": " & Split(StrTxt, ".")(0)
                'Insert the Caption on the row below the picture
                With oTbl.Rows(j + 1).Cells(1).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                            Label:="Photograph", Title:=strTitle, _
                            Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    If Not bHyphen = True Then
                        .Characters.Last.Previous = vbNullString
                    Else
                        .Characters.Last.Previous = Chr(32)
                    End If
                End With
                DoEvents
            Next
        Else
        End If
    End With
    Application.ScreenUpdating = True
End Sub