Create Table for Multiple Pictures

Hello, I've seen the code in http://www.vbaexpress.com/forum/show...nto-Word-Table and It's very similar to what I need but since I'm very new to VBA I'm asking for your assistance.
Here's what i'm trying to achieve.
I need to insert imagens in a table like the code presented here, but I don't need the captions, thats easy and I've solved this problem.
My goal is, a table with 3 columns and 3 rows.
The first one with 8.43cm with second 0.3 and third 8.43, the bigger ones will be the places for images. The height will be 11.1 on the first row and 0.7 on the second and third. I've tried with a variation of this code

Code:

---

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
    With oTbl
        With .Rows(x)
            .Height = InchesToPoints(Hght)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Normal"
        End With
        With .Rows(x + 1)
            .Height = CentimetersToPoints(0.5)
            .HeightRule = wdRowHeightExactly
            .Range.Style = "Caption"
        End With
    End With
End Sub

---

But I was unsuccessfull.

The second thing is, on the very first cell of each page I want to add a repeating text (like a title) instead of a picture (with an input box). Is this possible to do?

Cheers
Tiago

Please don't hijack existing threads for quite different issues - which is what yours are. After all, all you've indicated that you need is a single 3*3 table. For what you've described, all that's required is:

Code:

---

Sub AddTable()
Application.ScreenUpdating = False
Dim oTbl As Table
Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=3, NumColumns:=3)
With oTbl
  .AutoFitBehavior (wdAutoFitFixed)
  .PreferredWidthType = wdPreferredWidthPoints
  .PreferredWidth = CentimetersToPoints(17.16)
  With .Columns(1)
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(8.43)
  End With
  With .Columns(2)
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(0.3)
  End With
  With .Columns(3)
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(8.43)
  End With
  .Rows.Alignment = wdAlignRowCenter
  .Rows.HeightRule = wdRowHeightExactly
  .Rows(1).Height = CentimetersToPoints(11.1)
  .Rows(2).Height = CentimetersToPoints(0.7)
  .Rows(3).Height = CentimetersToPoints(0.7)
End With
Application.ScreenUpdating = True
End Sub

---

I have no idea what you mean by:

Quote:

---

Originally Posted by wave

The second thing is, on the very first cell of each page I want to add a repeating text (like a title) instead of a picture (with an input box).

---

since all you've specified is a table that would fit comfortably onto a single page.

Sorry maybe I din't explained myself correctly, here's what i mean:
Attachment 25610

Like this, the first cell of each page has the description, witch I intend to do as an input box. If I select 1 to 3 imagens it fills one page, 4 to 6 it fills the second and on and on.

Well, that's an entirely different table structure to what you first described. To start with, you have 5 rows (per page), not 3. Plus you require not 1 'input box', but 3. It would have been be helpful if you had specified your actual requirements in full from the outset. No-one enjoys re-writing code just because key details were omitted from the original specs...

Code:

---

Sub AddPicTable()
Application.ScreenUpdating = False
Dim oTbl As Table, Rng As Range, iShp As InlineShape
Dim c As Long, i As Long, j As Long, r As Long
'Select the pictures to insert
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  ' If nothing is selected, exit
  If .Show <> -1 Then Exit Sub
  On Error Resume Next
  'Create & define 3 paragraph Styles to be used in the first cell on each page
  With ActiveDocument
    .Styles.Add Name:="Title", Type:=wdStyleTypeParagraph
    .Styles.Add Name:="Sub-Title", Type:=wdStyleTypeParagraph
    .Styles.Add Name:="ID", Type:=wdStyleTypeParagraph
    On Error GoTo 0
    With .Styles("Title")
      With .ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .SpaceBefore = 48
        .SpaceAfter = 96
      End With
      With .Font
        .Name = "Arial"
        .Size = 24
      End With
    End With
    With .Styles("Sub-Title")
      With .ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .SpaceBefore = 24
        .SpaceAfter = 48
      End With
      With .Font
        .Name = "Arial"
        .Size = 16
      End With
    End With
    With .Styles("ID")
      With .ParagraphFormat
        .Alignment = wdAlignParagraphCenter
        .SpaceBefore = 12
        .SpaceAfter = 0
      End With
      With .Font
        .Name = "Arial"
        .Size = 12
      End With
    End With
  End With
  'Create the basic table and apply our Styles to the first cell
  Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=5, NumColumns:=3)
  With oTbl
    .AutoFitBehavior (wdAutoFitFixed)
    .PreferredWidthType = wdPreferredWidthPoints
    .PreferredWidth = CentimetersToPoints(17.16)
    .LeftPadding = 0: .RightPadding = 0
    .TopPadding = 0: .BottomPadding = 0
    .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    With .Range.ParagraphFormat
      .SpaceBefore = 0
      .SpaceAfter = 0
      .LineSpacingRule = wdLineSpaceSingle
    End With
    With .Columns(1)
      .PreferredWidthType = wdPreferredWidthPoints
      .PreferredWidth = CentimetersToPoints(8.43)
    End With
    With .Columns(2)
      .PreferredWidthType = wdPreferredWidthPoints
      .PreferredWidth = CentimetersToPoints(0.3)
    End With
    With .Columns(3)
      .PreferredWidthType = wdPreferredWidthPoints
      .PreferredWidth = CentimetersToPoints(8.43)
    End With
    .Rows.Alignment = wdAlignRowCenter
    .Rows.HeightRule = wdRowHeightExactly
    .Rows(1).Height = CentimetersToPoints(11.1)
    .Rows(2).Height = CentimetersToPoints(0.7)
    .Rows(3).Height = CentimetersToPoints(0.7)
    .Rows(4).Height = CentimetersToPoints(11.1)
    .Rows(5).Height = CentimetersToPoints(0.7)
    With .Cell(1, 1).Range
      .Text = vbCr & vbCr
      .Paragraphs(1).Style = "Title"
      .Paragraphs(2).Style = "Sub-Title"
      .Paragraphs(3).Style = "ID"
    End With
  End With
  'Replicate the basic table however many times are required
  Set Rng = oTbl.Range
  For i = 2 To -Int(.SelectedItems.Count / -3)
    With oTbl.Range
      .Collapse wdCollapseEnd
      .FormattedText = Rng.FormattedText
    End With
  Next
  'Insert the pictures
  c = 0: r = -1
  For i = 1 To .SelectedItems.Count
    Select Case i Mod 3
      Case 0: c = 3
      Case 1: c = 3: r = r + 2
      Case 2: c = 1: r = r + 3
    End Select
    Set iShp = oTbl.Range.InlineShapes.AddPicture( _
      FileName:=.SelectedItems(i), LinkToFile:=False, _
      SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
    'Resize undersize pictures
    With iShp
      .LockAspectRatio = True
      If .Width < oTbl.Cell(r, c).Width Then
        If .Height < oTbl.Cell(r, c).Height Then
          .Width = oTbl.Cell(r, c).Width
          If .Height > oTbl.Cell(r, c).Height Then
            .Height = oTbl.Cell(r, c).Height
          End If
        End If
      End If
    End With
  Next
  'Solicit the inputs & bookmark them
  With oTbl
    With .Cell(1, 1).Range
      Set Rng = .Paragraphs(1).Range
      Rng.Collapse wdCollapseStart
      Rng.Text = InputBox("Input a Title", "Title Input", "Title")
      .Bookmarks.Add "Title", Rng
      Set Rng = .Paragraphs(2).Range
      Rng.Collapse wdCollapseStart
      Rng.Text = InputBox("Input a Sub-Title", "Sub-Title Input", "Sub-Title")
      .Bookmarks.Add "SubTitle", Rng
      Set Rng = .Paragraphs(3).Range
      Rng.Collapse wdCollapseStart
      Rng.Text = InputBox("Input an ID", "ID Input", "ID")
      .Bookmarks.Add "ID", Rng
    End With
    'Cross-reference the bookmarks on each additional page
    For r = 6 To .Rows.Count Step 5
      With .Cell(r, 1).Range
        Set Rng = .Paragraphs(1).Range
        Rng.Collapse wdCollapseStart
        .Fields.Add Rng, wdFieldEmpty, "REF Title", False
        Set Rng = .Paragraphs(2).Range
        Rng.Collapse wdCollapseStart
        .Fields.Add Rng, wdFieldEmpty, "REF SubTitle", False
        Set Rng = .Paragraphs(3).Range
        Rng.Collapse wdCollapseStart
        .Fields.Add Rng, wdFieldEmpty, "REF ID", False
      End With
    Next
    .Range.Fields.Update
  End With
End With
Application.ScreenUpdating = True
End Sub

---

Sorry, I thought the table with 3r and 3c, could fit on one page. In the other computer It does, must be the margins.
Thank you for the code, it works great

Cheers

As coded, the result on my system is as per the images in your post #3, with an A4 page size using 25mm margins all round (the table is wider than the margins provide for, though).

Thank you for all your help, It works great, now I'm trying to learn and understand all the code you wrote since I'm new at this.

Cheers

I've added some comments to the code to describe what's being done in each part.

Thank you Paul,
Just one more thing, how can i autofit the pics to the cells size? I can only fit the first one.

Unless they're too small, the pics will automatically scale to achieve a best-fit in the cells at the correct aspect ratio. And, unless they're in portrait format with a 1.326:1 (or 1:0.754) h:w aspect ratio, making them fill the cells would result in either a distortion of the aspect ratio or cropping of the image.

I think they're too big. But When i format them manualy, only changing the h to 11 (the w also changes automaticaly), they fit perfectly to the table.

When Word inserts a picture into a table cell with a fixed height and width, any image that is too big to fit within the cell at the correct aspect ratio is scaled down to fit. The behaviour is by design. Unless your 'Normal' paragraph format applies a non-zero 'space before' and/or 'space after', it's impossible for your images to be 'too big' and require scaling up to fit.

Thank you for the trouble. You've been very helpfull :D
I'll try to see what I can do, and if i figure something out I'll post it here.

Cheers

I've added some code to resize any undersize pictures.

Thank you. Actually I worked it out this afternoon but I left the code on the other computer. Since all my imagens follow the aspect 7:5 and I don't mind a little distortion I defined the resize of every picture to 11:8 and it worked.
Now I'm working on the text of the first cell to always be correctly sized no matter the number of characters that I write. For example if the title has a lot of characters the ID disappears. I think I'll need a few "if" conditions but I hadn't thought a lot about it.

You're great at vba and I really appreciate the time you've dedicated to this. Thank you!
Cheers

Quote:

---

Originally Posted by wave

Since all my imagens follow the aspect 7:5 and I don't mind a little distortion I defined the resize of every picture to 11:8 and it worked.

---

In that case, you really should have given the cells the 7:5 aspect ratio (e.g. 11.1cm*7.93cm and an overall table width of 16.16cm [which would also be a better fit on the page]). That way you wouldn't need to distort or resize the pics.

Quote:

---

Originally Posted by wave

Now I'm working on the text of the first cell to always be correctly sized no matter the number of characters that I write. For example if the title has a lot of characters the ID disappears. I think I'll need a few "if" conditions but I hadn't thought a lot about it.

---

In that case, you can change the before/after paragraph space settings and/or the font size for one or more of the Styles so that you don't run out of space.

Yes that seams a good idea. But i don't see almost any distortion. Tomorrow I'll change it.
As for the other part, I've changed it already and for most titles and sub titles it works. But like I said there are some texts that are too big and I just need to make it adjustable.

One more question I've added a fixed text to the 2 and 5th rows but when I add a new style to format the text and then call it afterwards it gives me and error and it doesn't go past it, any ideia about what it could be?

Quote:

---

Originally Posted by wave

Yes that seams a good idea. But i don't see almost any distortion. Tomorrow I'll change it.
As for the other part, I've changed it already and for most titles and sub titles it works. But like I said there are some texts that are too big and I just need to make it adjustable.

---

As I said, though, changing the before/after paragraph space settings and/or the font size for one or more of the Styles should take care of that.

Quote:

---

Originally Posted by wave

One more question I've added a fixed text to the 2 and 5th rows but when I add a new style to format the text and then call it afterwards it gives me and error and it doesn't go past it, any ideia about what it could be?

---

Without seeing how you've implemented that, I can't say.

I followed your advice and aplied this

Code:

---

With ActiveDocument
    For i = 1 To .InlineShapes.Count
        With .InlineShapes(i)
            .Height = CentimetersToPoints(11.1)
            .Width = CentimetersToPoints(7.93)
        End With
    Next i
  End With

---

It's simple and it works fine. Today I haven't had much time to make more adjustments but on the first cell I made the changes that you've sugested. As far as Styles go, I don't think I need it anymore :D

That is NOT what I said you should do. What I said is that you should change the column widths and table width...