Sub InsertMultipleImagesFixed()
    Dim fd As FileDialog
    Dim imgCount As Long
    Dim imgTable As Table
    Dim index As Long
    Dim img As InlineShape
    Dim imageLoc As Variant

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "Select image files and click OK"
        .Filters.Add "Images", _
            "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
        .FilterIndex = 2
    End With
    If fd.Show = -1 Then
        imgCount = fd.SelectedItems.Count

        With ActiveDocument
            With .Content.Find
                .Replacement.ClearFormatting
                .Text = "TotalImageNumber"
                .Replacement.Text = imgCount
                .Execute Replace:=wdReplaceAll
            End With
            Set imgTable = .Tables.Add(Range:=.Characters.Last, NumRows:=imgCount, NumColumns:=2)
        End With

        'apply table settings
        With imgTable
            .Borders.Enable = False
            .PreferredWidthType = wdPreferredWidthPercent
            .PreferredWidth = 100
            .Rows.Alignment = wdAlignRowLeft
            .Columns(1).Width = 140
            .Columns(2).Width = 400
        End With
        
        'loop through table adding images and text
        For index = 1 To imgCount

            With imgTable.Cell(index, 1).Range
                With .ParagraphFormat
                    If index > 1 Then .SpaceBefore = 12
                End With
                With .Font
                    .Size = 12
                    .Underline = wdUnderlineSingle
                End With
                .Text = "Photograph No. " & index & ":"
                .Characters(.Characters.Count - 1).Font.Underline = wdUnderlineNone
                .InsertParagraphAfter
                With .Paragraphs.Last.Range
                    .Font.Underline = wdUnderlineNone
                    With .ParagraphFormat
                        .RightIndent = InchesToPoints(0.02)
                        .SpaceBefore = 0
                        'the following are likely unnecessary
                        '.SpaceBeforeAuto = False
                        '.SpaceAfterAuto = False
                    End With
                End With
            End With
            With imgTable.Cell(index, 2).Range.ParagraphFormat
                .RightIndent = InchesToPoints(0.01)
                If index > 1 Then .SpaceBefore = 12
                'the following are likely unnecessary
                '.SpaceBeforeAuto = False
                '.SpaceAfterAuto = False
            End With
            'insert image
            Set img = _
                ActiveDocument.InlineShapes.AddPicture(FileName:=imageLoc & fd.SelectedItems(index), _
                LinkToFile:=False, SaveWithDocument:=True, Range:=imgTable.Cell(index, 2).Range)

            'resize image
            With img
                With .Fill
                    .Visible = msoFalse
                    .Solid
                    .Transparency = 0
                End With
                With .Line
                    .Weight = 0.75
                    .Transparency = 0#
                    .Visible = msoFalse
                End With
                'I suspect the above should simply be
                '.Fill.Visible = msoFalse
                '.Line.Visible = msoFalse
                
                .LockAspectRatio = msoTrue
                .Height = 288
                .Width = 383.75
                With .PictureFormat
                    .Brightness = 0.5
                    .Contrast = 0.5
                    .ColorType = msoPictureAutomatic
                    'these should all be unnecessary
                    '                    .CropLeft = 0#
                    '                    .CropRight = 0#
                    '                    .CropTop = 0#
                End With
            End With
        Next index
    End If
End Sub