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/showthread.php?60523-Macro-to-insert-4-images-per-page-picture-name-picture-reference-and-additional-row&p=368090&viewfull=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-vba/16772-4-digital-images-1-page.html#post47919