Add Pictures to Table

Hello all,

In the AddPics macro in http://www.vbaexpress.com/forum/show...l=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
Attachment 26274

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

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

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.

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

Code:

---

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

---

Attachment 26276

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

Yes that worked. Thanks so much Paul!

Quote:

---

Originally Posted by macropod

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

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

Attachment 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....aq_req_help_pm

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