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_p...ry_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!