Automatically Generated Table Need to be Split after Every 2 Rows

[matt stiles]

Hey All,

The following code allows users to select and insert multiple pictures into a word doc by generating 2 table rows and inserting the picture in the first row and the file name in the 2nd row. The process continues for the number of pictures selected. There are no breaks in this table; it is one long table.

I'd like the picture and accompanying file name to be inserted into a 2-row table, followed by a line break, and for this to be done to every picture inserted at one time.




Private Sub CommandButton15_Click()

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 line break so the bookmark isn't nested in the table and you can continue to add update doc
'and add pictures.
Selection.GoTo What:=wdGoToBookmark, Name:="bm1"
Selection.InsertBreak Type:=wdLineBreak

'Add a 2-row by 1-column table with Autofit to window columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
With oTbl
.AutoFitBehavior (wdAutoFitWindow)
.Columns.Width = CentimetersToPoints(1)
.Rows.Alignment = wdAlignRowCenter
'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

'wdrowheightatleast allows the contents to wrap in the caption cell

Sub FormatRows(oTbl As Table, x As Long)




With oTbl
With .Rows(x)
.Height = CentimetersToPoints(1)
.HeightRule = wdRowHeightAtLeast
.Range.Style = "Graphic"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightAtLeast
.Range.Style = "Caption"
End With
End With




Please let me know if you have any questions. Thank you for whatever help you may provide.

-Matt

[gmaxey]

Maybe something like this:

But you mind find this useful: http://gregmaxey.mvps.org/word_tip_pages/photo_gallery_add_in.html


Private Sub CommandButton15_Click()
Dim oRng As Range

'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 line break so the bookmark isn't nested in the table and you can continue to add update doc
'and add pictures.
'Selection.GoTo What:=wdGoToBookmark, Name:="bm1"
'Selection.InsertBreak Type:=wdLineBreak
For i = 1 To .SelectedItems.Count
'Add a 2-row by 1-column table with Autofit to window columns to take the images
Set oTbl = Selection.Tables.Add(Selection.Range, 2, 1)
With oTbl
.AutoFitBehavior (wdAutoFitWindow)
.Columns.Width = CentimetersToPoints(1)
.Rows.Alignment = wdAlignRowCenter
'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(1).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(2).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
Set oRng = oTbl.Range
oRng.Collapse wdCollapseEnd
oRng.Move wdParagraph, 1
oRng.InsertBefore Chr(11)
oRng.Collapse wdCollapseEnd
oRng.Select
Next
Else
End If
End With
Application.ScreenUpdating = True

End Sub

[matt stiles]

Fantastic Greg. Thanks for all of your help. Happy Holidays!