Insert Multiple Pictures Into Table Word With Macro

**Novio** · 11-23-2012, 04:08 AM

Hello,
I would like to use a macro to insert several pictures in a table. In the first row the picture and in the second row the text "Pictures x"
look like attachment.
A have a bit of code.
[vba]
Sub Test()
'
' Test Macro
'
'
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
'Add a 1 row 2 column table to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2)
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
End With
With oTbl.Rows.First
.Height = CentimetersToPoints(7)
.HeightRule = wdRowHeightExactly
End With
With oTbl.Columns.First
.Width = CentimetersToPoints(7)
End With
With oTbl.Columns.Last
.Width = CentimetersToPoints(7)
End With
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
CaptionLabels.Add Name:="Picture"
For Each vrtSelectedItem In .SelectedItems
With Selection
Set oILS = .InlineShapes.AddPicture(FileName:= _
vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
Range:=Selection.Range)
oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
.MoveRight wdCell, 1
End With
Next vrtSelectedItem
Else
End If
End With
If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete
Set fd = Nothing
End Sub
[/vba]

**fumei** · 11-23-2012, 09:18 AM

What exactly aee you asking?

**macropod** · 11-23-2012, 04:32 PM

I believe the OP wants to be able to select multiple pictures and insert them into a table, with pictures on the odd rows and their captions on the even rows. To that end, try:

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
        Else
        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

As coded, the paragraph Style for the image rows is set to 'Normal'. I suggest creating another paragraph Style, with 0 space before and after, plus the 'Keep with next' attribute, and using that instead of the 'Normal' Style.

**gsinclair** · 08-15-2013, 03:56 AM

Paul,

Have seen this very useful bit of code and was wondering if you could assist in modifying it for a particular end purpose?

Essentially as written, but with a single column, so that there are only 2 images per page. Can you assist?

Thanks
George

Originally Posted by macropod

I believe the OP wants to be able to select multiple pictures and insert them into a table, with pictures on the odd rows and their captions on the even rows. To that end, try:

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
        Else
        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

As coded, the paragraph Style for the image rows is set to 'Normal'. I suggest creating another paragraph Style, with 0 space before and after, plus the 'Keep with next' attribute, and using that instead of the 'Normal' Style.

**bilareal** · 06-06-2014, 07:47 AM

Hello,

Isn't possible in a 2 columns model insert the photo only in the left cell of the line, and let free the right cell to make a description text?
And insert the caption and photo in the same cell (caption above the photo)?

**macropod** · 06-06-2014, 03:44 PM

Originally Posted by bilareal

Hello,

Isn't possible in a 2 columns model insert the photo only in the left cell of the line, and let free the right cell to make a description text?
And insert the caption and photo in the same cell (caption above the photo)?

Not with that macro. A completely different one would be required for that.

**bilareal** · 06-08-2014, 06:14 AM

Originally Posted by macropod

Not with that macro. A completely different one would be required for that.

I tried this, but i can't get fix the error in the caption!

Sub InsertMultipleImagesWithFilename()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275

If Documents.Count = 0 Then
sNoDoc = MsgBox(" " & _
"No document open!" & vbCr & vbCr & _
"Do you wish to create a new document to hold the images?", _
vbYesNo, "Insert Images")
If sNoDoc = vbYes Then
Documents.Add
Else
Exit Sub
End If
End If

'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 2)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
'find col,row #s
If i Mod 2 = 0 Then 'even number right column
iRow = i / 2
iCol = 2
Else 'odd number left column new row
iRow = (i + 1) / 2
iCol = 1
End If
iRow = i
iCol = 1

'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)

'select cell
Set oCell = oTable.Cell(iRow, iCol).Range

'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell

'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If

'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphLeft

'insert caption above image
oCell.InlineShapes(1).Range.InsertCaption Label:="imagem", TitleAutoText:="", _
Title:=":" & picName, Position:=wdCaptionPositionAbove, ExcludeLabel:=True

If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If

If i < .SelectedItems.Count Then 'add another row, more to go
oTable.Rows.Add
End If

Next i
End If
End With

Set fd = Nothing
End Sub

**lalli** · 06-21-2016, 11:42 PM

Nice!

**fumei** · 11-23-2012, 08:32 PM

I'm sorry, but I just have to grin. Nice one Paul.

**macropod** · 11-23-2012, 09:10 PM

That's far better than a grimmace ....

**fumei** · 11-23-2012, 10:17 PM

hee hee hee, there is that isn't there? Ah choices...

**gmaxey** · 11-24-2012, 11:00 AM

I don't know if you will grin or grimmace, but I published an add-in for doing something similar a could have months ago:

http://gregmaxey.mvps.org/word_tip_p...ry_add_in.html

**fumei** · 11-24-2012, 11:19 AM

Greg, would it be possible that I get to see the source code for that?

**gmaxey** · 11-24-2012, 03:43 PM

Gerry, send website feedback and we'll discuss offline via e-mail (since your private message box is full).

**Novio** · 11-26-2012, 12:24 AM

@Paul Edstein
Thanks, this is what I was looking for.

Kind regards

Mark

**macropod** · 09-30-2013, 11:41 PM

Hi George,

I've been OS for 3½ months, hence the delay in replying. Have you resolved the issue, or do you still need help?

**gsinclair** · 10-01-2013, 02:07 AM

Originally Posted by macropod

Hi George,

I've been OS for 3½ months, hence the delay in replying. Have you resolved the issue, or do you still need help?

No solution as yet Paul, so would really appreciate any help!

cheers
George

**macropod** · 10-01-2013, 02:33 AM

Try the following. Only a few minor changes were needed:

Sub AddPics()
    Application.ScreenUpdating = False
    Dim oTbl As Table, i As Long, j 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 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(7)
                 'Format the rows
                Call FormatRows(oTbl, 1)
            End With
            CaptionLabels.Add Name:="Picture"
            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:="Picture", Title:=StrTxt, _
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False
                    .Characters.First = vbNullString
                    .Characters.Last.Previous = vbNullString
                End With
            Next
        Else
        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

**Mark90** · 10-04-2013, 04:33 AM

I don't know if you will grin or grimmace, but I published an add-in for doing something similar a could have months ago:

This is great Greg, I could see me using very soon. Thanks for posting. Now reading everything on your site

**princess** · 10-17-2013, 11:09 AM

Can someone please help me with putting the caption on the row above the photo and ommitting adding "Picture '#':" to the caption? And the caption shows up blue, is there a way to ensure the text is black?

I am trying to use the macro that macropod had posted on this thread.

Thread: Insert Multiple Pictures Into Table Word With Macro

Thread Tools

Display

Hybrid View

Insert Multiple Pictures Into Table Word With Macro

modification to code

Posting Permissions