Macro to insert images into table

I am trying to create a Macro for Word, where I can select multiple pictures and insert them into a table, 2 Columns wide, with pictures on the odd rows and their captions on the even rows. I want to resize each picture to 8cm wide, and have no borders on the table.


I have attached images of the end result I am trying to achieve (minus the visible borders).

Any help would be appreciated a lot, cheers.
Below is the closest code I have found to what I want. The code is from the user macropod, on here. :)
Attachment 26240

Code:

---

Sub AddPics()
    Application.ScreenUpdating = False
   
    Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
   
    '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   
            'Add a 2-row by 2-column table with 7cm columns to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = CentimetersToPoints(7)
                'Format the rows
                Call FormatRows(oTbl, 1)
            End With
   
            CaptionLabels.Add Name:="Picture"
           
            For i = 1 To .SelectedItems.Count   
                j = Int((i + 1) / 2) * 2 - 1
                k = (i - 1) Mod 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(k).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(k).Range
                    .InsertBefore vbCr
                    .Characters.First.InsertCaption _
                    Label:="Picture", Title:=StrTxt, _
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    .Characters.Last.Previous = vbNullString
                End With               
            Next
    End If   
End With
Application.ScreenUpdating = True
End Sub
    '
Sub FormatRows(oTbl As Table, x As Long)
    With oTbl
        With .Rows(x)
            .Height = CentimetersToPoints(7)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.75)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

---

After:
With oTbl
insert:
.Borders.Enable = False


You should also change:
.Columns.Width = CentimetersToPoints(7)
to:
.Columns.Width = CentimetersToPoints(8)

You might also find it useful to change:
.Height = CentimetersToPoints(7)
to something more closely approximating the required picture height. If they're only in landscape format with the typical 3:2 aspect ratio, you might use:
.Height = CentimetersToPoints(5.33)
For pics using a 4:3 ratio, you might use:
.Height = CentimetersToPoints(6)
But, if you have a mix of pics in portrait and landscape orientation, you'd probably want to use:
.Height = CentimetersToPoints(8)

The table leaves large gaps after every image, how would I remove these?
The images are a mix of landscape and portrait.
Also the text is blue, what could i change to make it black?

Below is an image of the result with the current code.
Cheers for the help Paul.

Attachment 26241

Quote:

---

Originally Posted by neoncake

The table leaves large gaps after every image, how would I remove these?

---

Did you read what I said in my previous reply about the image heights?

Quote:

---

Originally Posted by neoncake

The images are a mix of landscape and portrait.

---

The images in your post are only in landscape format. If you change the row heights to suit landscape images, your portrait images will be scaled down to suit that height.

Another approach would be to insert:
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
or:

.Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom

after:
With oTbl
to change where the images sit within their cells.

Quote:

---

Originally Posted by neoncake

Also the text is blue, what could i change to make it black?

---

By changing the Caption Style.

Quote:

---

Originally Posted by macropod

Did you read what I said in my previous reply about the image heights?


The images in your post are only in landscape format. If you change the row heights to suit landscape images, your portrait images will be scaled down to suit that height.

Another approach would be to insert:
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
or:

.Range.Cells.VerticalAlignment = wdCellAlignVerticalBottom

after:
With oTbl
to change where the images sit within their cells.

By changing the Caption Style.

---

Ahh i misread, thanks. I've got a few portrait photos so i'll try stick with 8cm for now.

Thankyou for your help, I really appreciate it!

See also https://www.gmayor.com/photo_gallery_template.html