Batch Insert Pictures into Word Table with Stored Information

[mrhurley]

I have seen some previous excellent posts on this form that I have followed and got me close to where I want to be. I am scratching around trying to get the macro to do what I want and an asking for help. I want to recreate the table in the attachment while batch importing photos. The location, description, and date information are the same for each photo. I just want to define that information via a prompt, choose the photos to be inserted, and have the Macro build the table for me rather than having to drop and drag each one individually and update everything manually. Work smarter, not harder.



I am following this very good thread (https://www.msofficeforums.com/drawi...-document.html) as a guide, but need some help. Thanks in advance!

[gmayor]

You may find Photo Gallery Add-in Template is capable of doing what you require.

[mrhurley]

Thanks. I will take a look.

[macropod]

For example, based on the code in the thread you linked to:

Sub AddPicsWithCaption()
'Sourced from: https://www.msofficeforums.com/word-vba/53656-batch-insert-pictures-into-word-table-stored.html
Application.ScreenUpdating = False
Dim Stl As Style, 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
StrTxt = InputBox("Input Caption Details as: XXX|YYY|ZZZ for:" & vbCr & "LOCATION: XXX | DESCRIPTION: YYY | DATE: ZZZ")
If UBound(Split(StrTxt, "|")) < 2 Then Exit Sub
StrTxt = "LOCATION: " & Split(StrTxt, "|")(0) & Chr(11) & _
        "DESCRIPTION: " & Split(StrTxt, "|")(1) & Chr(11) & _
        "DATE: " & Split(StrTxt, "|")(2)
With ActiveDocument.PageSetup
  TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
ColWdth = PointsToCentimeters(TblWdth / NumCols)
ColWdth = CentimetersToPoints(CSng(InputBox("What max width for the pictures, in Centimeters (e.g. " & Format(ColWdth, "0.00") & ")?")))
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
    With ActiveDocument
      On Error Resume Next
      Set Stl = .Styles("TblPic")
     If Stl Is Nothing Then Set Stl = .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 oTbl
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
    End With
    CaptionLabels.Add Name:="Picture"
    For i = 1 To .SelectedItems.Count Step NumCols
      r = oTbl.Rows.Count - 1
      'Format the rows
      Call FormatRows(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
        'Insert the Caption on the row below the picture
        oTbl.Cell(r, c).Range.Text = StrTxt
        '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 FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x + 1)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x)
    .Height = CentimetersToPoints(1.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Normal"
  End With
End With
End Sub

[mrhurley]

Thanks for the help. Got me where I wanted to go. One question as I try to understand the solution is the last line below:

With oTbl
With .Rows(x + 1)
.Height = Hght

"Hght" doesn't seem to be defined anywhere. Is this a universal variable or am I missing something.

Also - is there a way to inside a page break after every fourth row so I always start a page with a caption row. Tried adjusting the row height and even defining a new variable making the RwHght as (.PageHeight - .TopMargin - .BottomMargin - [fixed value of caption box/2]) / 2, but it kept making the row with the picture super skinny

[macropod]

Originally Posted by mrhurley

One question as I try to understand the solution is the last line below:

With oTbl
With .Rows(x + 1)
.Height = Hght

"Hght" doesn't seem to be defined anywhere. Is this a universal variable or am I missing something.

It's defined at:
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)

Originally Posted by mrhurley

Also - is there a way to inside a page break after every fourth row so I always start a page with a caption row.

Inserting page breaks breaks the table into multiple separate tables and would require a significant re-write of the code. You should be able to achieve the same result by changing the TblPic Style's 'Keep With Next' attribute. To do that change:
.KeepWithNext = True
to
.KeepWithNext = False
and by inserting
.KeepWithNext = True
after:
.Range.Style = "Normal"
in the FormatRows sub.