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
Reply With Quote
Originally Posted by wave
