Add Pictures to Table

[bkb146]

Hello all,

In the AddPics macro in http://www.vbaexpress.com/forum/showthread.php?67056-Macro-to-insert-images-into-table&p=400370&viewfull=1#post400370 is there a way to insert a page break so that there are 4 pics with captions per page?

I'm trying to input about 100 graphs but can only have 4 per page in a 2x2 table. I tried adjusting the spacing but the caption row for images 5 and 6 would always appear on the first page instead of the second page
26274

[macropod]

Simply add the 'keep with next' paragraph format to the Caption Style

[bkb146]

Thank you for the reply, that did not seem to work. Could it be because I have the captions above the images?

[macropod]

That suggets you may have content other than just the caption in the caption rows.

Without actually seeing the problem document, however, it can be difficult for anyone to diagnose the issue. Can you attach a document to a post with some representative data (delete anything sensitive)? You do this via the paperclip symbol on the 'Go Advanced' tab at the bottom of this screen.

[bkb146]

A document is attached, and this is the macro I'm using. Greatly appreciate the assistance


Sub AddPics2()
Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long, iShp As InlineShape
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RwHght = CentimetersToPoints(CSng(InputBox("What max height for the pictures, in centimeters (e.g. 5)?")))
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
'Create a paragraph Style with 0 space before/after & centre-aligned
On Error Resume Next
With ActiveDocument
.Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
On Error GoTo 0
With .Styles("TblPic").ParagraphFormat
.Alignment = wdAlignParagraphCenter
.KeepWithNext = True
.SpaceAfter = 0
.SpaceBefore = 0
End With
End With
'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 ActiveDocument.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
ColWdth = TblWdth / NumCols
End With
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = ColWdth
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count Step NumCols
r = ((i - 1) / NumCols + 1) * 2 - 1
'Format the rows
Call FormatRows2(oTbl, r, RwHght)
For c = 1 To NumCols
j = j + 1
'Insert the Picture
Set iShp = ActiveDocument.InlineShapes.AddPicture( _
FileName:=.SelectedItems(j), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(r + 1, c).Range)
With iShp
.LockAspectRatio = True
If (.Width < ColWdth) And (.Height < RwHght) Then
.Width = ColWdth
If .Height > RwHght Then .Height = RwHght
End If
End With
'Get the Image name for the Caption
StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
StrTxt = ": " & Split(StrTxt, ".")(0)
'Insert the Caption on the row above the picture
With oTbl.Cell(r, c).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
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
End If
Next
Else
End If
End With


ErrExit:
Application.ScreenUpdating = True
End Sub


Sub FormatRows2(oTbl As Table, x As Long, Hght As Single)
With oTbl
With .Rows(x)
.Height = CentimetersToPoints(0.5)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
With .Rows(x + 1)
.Height = Hght
.HeightRule = wdRowHeightExactly
.Range.Style = "TblPic"
.Cells.VerticalAlignment = wdCellAlignVerticalCenter

End With
End With
End Sub


26276

[macropod]

The problem is that the cell containing the pics also has the 'keep with next' property set. Change:
.KeepWithNext = True
to:
.KeepWithNext = False

[bkb146]

Yes that worked. Thanks so much Paul!

[Puca]

The problem is that the cell containing the pics also has the 'keep with next' property set. Change:
.KeepWithNext = True
to:
.KeepWithNext = False

Thank you very much, this is what I also need. I am using your macro for adding picture into a table word. It's very useful for me but when I select the picture file from msoFileDialogFilePicker, the selected files are auto sorted alphabetically (or algorithm) in the string array therefore the pictures inserted into word table as that order. But I want the pictures added as the order when I select them from the filepicker dialog one by one. Could you show me how to get this by change the macro or show me where I was wrong in using.

P/s: I did not see where to start a new thread (and you did not accept private message also) so I reply to this thread to ask for your help

[Paul_Hossler]

You can start a new thread by using the [+ Post New Thread] button

29452


You should take a few minutes to look at the FAQ

http://www.vbaexpress.com/forum/faq.php


Especially

http://www.vbaexpress.com/forum/faq.php?faq=psting_faq_item#faq_req_help_pm

http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3