vba to insert multiple pictures in a table with one row above for caption (pic shown

[sarveshspace]

Hello,
I want to select multiple pictures via dialogue box and insert them in a table . There should be one row above each row of pics for captions. I have attached an email showing what i want to do.
The background color of the caption row should be black and text as while.
ex - rw 1 caption row
rw 2 pictures
rw 3 caption row
rw 4 pictures and so on .
Each picture row must have only 3 pics.
I am a beginner in vba coding. I would greatly appreciate any help as to how this can be done.
Thanks!

[macropod]

As forum search would turn up numerous threads & posts on this. See, for example: http://www.vbaexpress.com/forum/show...l=1#post368090

[sarveshspace]

hi macropod,

I have used one of your codes and made a little changes to it . I do not know what i am doing wrong.
I want my pictures to have caption above them .So pic row is even and caption row is odd.

Here is the code i am using based on your input. However, i am getting additional empty rows after my pictures are inserted.

Sub AddPics()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
    Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
    On Error GoTo ErrExit
    NumCols = 3
    RwHght = CSng(3.8)
    On Error GoTo 0
     '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 NumCols-column table to take the images
            Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)


            With oTbl
                .Borders.Enable = True
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = InchesToPoints(2.4)
            End With
            CaptionLabels.Add Name:="Picture"

      ' Possible problem region 


            For i = 1 To .SelectedItems.Count Step NumCols
                r = ((i + 1) / NumCols + 1) * 2 - 1
                 'Format the rows
                Call FormatRows(oTbl, r, RwHght)
               
                
                For c = 1 To NumCols
                    j = j + 1
                     'Insert the Picture
                    ActiveDocument.InlineShapes.AddPicture _
                    FileName:=.SelectedItems(j), LinkToFile:=False, _
                    SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                     'Get the Image name for the Caption
                    StrTxt = Split(Split(.SelectedItems(j), "")(UBound(Split(.SelectedItems(j), ""))))(0)
                     'Insert the Caption on the row below the picture
                    With oTbl.Cell(r - 1, c).Range
                        .Text = StrTxt
                    End With
                    
                     'Exit when we're done
                    If j = .SelectedItems.Count Then Exit For
                Next
                 'Add extra rows as needed
                If j < .SelectedItems.Count Then
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                    oTbl.Rows.Add
                End If
            Next
        Else
        End If
    End With
ErrExit:
    Application.ScreenUpdating = True
End Sub
 '
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x - 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Shading.BackgroundPatternColor = wdColorBlack


            With .Range
              .Style = "Normal"
              With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceAfter = 0
                
              End With
            End With
        End With
        With .Rows(x)
            .Height = CentimetersToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            With .Range
              .Style = "Normal"
              With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceAfter = 0
              End With
            End With
        End With
       
    End With
End Sub

[sarveshspace]

no worries, i fixed it ! just removed one repetition of tbl.rows.add

thanks!

[macropod]

For the code changes needed to swap the order, see: http://www.msofficeforums.com/word-v...html#post47919