I have a macro to auto insert pictures in a table. Need help with format though.

[frewert]

Code by Macropod

Sub AddPics()
    Application.ScreenUpdating = False
    Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
    Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
    On Error GoTo ErrExit
    NumCols = CLng(InputBox("How Many Columns per Row?"))
    RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.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
             '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
            End With
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns.Width = TblWdth / NumCols
            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 FormatRows(oTbl, r, RwHght)
                For c = 1 To NumCols
                    j = j + 1
                     'Insert the Picture
                    ActiveDocument.InlineShapes.AddPicture _
                    FileName:=.SelectedItems(j), LinkToFile:=False, _
                    SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
                     '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 below the picture
                    With oTbl.Cell(r + 1, 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 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

As is, this puts unnecessary space between the caption and the image. I need to reduce this to nothing.
This might solve the issue where the text of row 1 captions are touching row 2 pictures.
Also, I would like make each caption say "Sample: [the image filename]"
Bonus, if you can make everything Left aligned instead of Center.

 

[ZVI]

To resize inserted pictures by cells margins replace this part of the code:

          'Insert the Picture
          ActiveDocument.InlineShapes.AddPicture _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range

by that one:

          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoFalse
              .Height = oTbl.Cell(r, c).Height
              .Width = oTbl.Cell(r, c).Width
          End With
          oTbl.Cell(r, c).Range.ShapeRange.ZOrder msoBringToFront

This excludes gaps between inserted pictures and their captions.
And you may also replace in the code Label:="Picture" by Label:="Sample" if you prefer that word in caption.

 

[frewert]

To resize inserted pictures by cells margins replace this part of the code:

          'Insert the Picture
          ActiveDocument.InlineShapes.AddPicture _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range

by that one:

          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoFalse
              .Height = oTbl.Cell(r, c).Height
              .Width = oTbl.Cell(r, c).Width
          End With
          oTbl.Cell(r, c).Range.ShapeRange.ZOrder msoBringToFront

This excludes gaps between inserted pictures and their captions.
And you may also replace in the code Label:="Picture" by Label:="Sample" if you prefer that word in caption.

Thank you for your reply! The gap is gone which is a major improvement. How can I get it to read "Sample: [filename]" and not "Sample 1: [filename]", I need to get rid of the counting digit before the colon.

Also, is there a way to pad the distance between the caption and the next inserted row? Right now, the caption letters are being cut off by the next rows pictures. Edit: I see that the caption row is a height of .2, when I manually make it a .3 it looks good. Maybe that can be part of the code?

Edit2: I see if change the height of the pictures they don't retain their original aspect ratio, can this be modified easily?

Thanks for your help!

 

[frewert]

Another thought: Its not that I need more space around the caption text. I think the caption text height property is too small for its font size. I just need a way to increase the height property.

Edit: I figured it out, so easy. The second sub has the height property already at 0.5. I changed to 1 and its perfect!

Now to just get rid of the Picture counting.

 

[frewert]

Any ideas on how to get rid of the counting, Example 1: [filename], Example 2: [filename], ...
I only need Example: [filename]

 

[frewert]

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

        End With
    End With
End Sub

Decreasing the left indent works for centering things for me manually. Thought I would try adding .Leftindent = -0.5
It didn't do anything though.

 

[ZVI]

How can I get it to read "Sample: [filename]" and not "Sample 1: [filename]", I need to get rid of the counting digit before the colon.
...
I see if change the height of the pictures they don't retain their original aspect ratio, can this be modified easily?

To get rid of the counting digit and to use original aspect ratio try the below code.
Please take into account that original aspect ratio may cause the gap between picture and its caption placed into the next row of the table.
Make grid of the table visible to see why the gap happens.

Sub AddPics()
  Application.ScreenUpdating = False
  Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
  Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
  On Error GoTo ErrExit
  NumCols = CLng(InputBox("How Many Columns per Row?"))
  RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.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
      '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
      End With
      With oTbl
        .AutoFitBehavior (wdAutoFitFixed)
        .Columns.Width = TblWdth / NumCols
      End With
      For i = 1 To .SelectedItems.Count Step NumCols
        r = ((i - 1) / NumCols + 1) * 2 - 1
        'Format the rows
        Call FormatRows(oTbl, r, RwHght)
        For c = 1 To NumCols
          j = j + 1
          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoTrue
              .Height = oTbl.Cell(r, c).Height
              If .Width > oTbl.Cell(r, c).Width Then
                .Width = oTbl.Cell(r, c).Width
              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 file name on the row below the picture
          oTbl.Cell(r + 1, c).Range.Characters.First.InsertAfter "Sample" & 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

 

[ZVI]

Here is the revised full code:

Sub AddPics()
  Application.ScreenUpdating = False
  Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
  Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
  On Error GoTo ErrExit
  NumCols = CLng(InputBox("How Many Columns per Row?"))
  RwHght = CSng(InputBox("What row height for the pictures, in inches (e.g. 1.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
      'Add a 2-row by NumCols-column table to take the images
      Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
      ' Set zero padding
      With oTbl
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .AllowPageBreaks = True
        .AllowAutoFit = False
      End With
      ' Set columns width
      With ActiveDocument.PageSetup
        TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      End With
      With oTbl
        .AutoFitBehavior wdAutoFitFixed
        .Columns.Width = TblWdth / NumCols
      End With
      ' Main
      For i = 1 To .SelectedItems.Count Step NumCols
        r = ((i - 1) / NumCols + 1) * 2 - 1
        'Format the rows
        Call FormatRows(oTbl, r, RwHght)
        For c = 1 To NumCols
          j = j + 1
          'Insert the Picture
          With ActiveDocument.InlineShapes.AddPicture( _
              Filename:=.SelectedItems(j), LinkToFile:=False, _
              SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range)
              .LockAspectRatio = msoTrue
              .Height = oTbl.Cell(r, c).Height
              If .Width > oTbl.Cell(r, c).Width Then
                .Width = oTbl.Cell(r, c).Width
              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 onto the row below the picture
          oTbl.Cell(r + 1, c).Range.Characters.First.InsertAfter "Sample" & 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
    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)
      .Height = InchesToPoints(Hght)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleNormal ' "Normal"
      .Cells.VerticalAlignment = wdCellAlignVerticalBottom
    End With
    With .Rows(x + 1)
      .Height = CentimetersToPoints(1)
      .HeightRule = wdRowHeightExactly
      .Range.Style = wdStyleCaption ' "Caption"
      .Cells.VerticalAlignment = wdCellAlignVerticalTop
    End With
  End With
End Sub

Hope this code is close to what you are asking for.
Change it according to your preferences.

 

[frewert]

Thank you, this is really close to what I need. The only thing now is adjust the .LeftIndent property for each row of the table.

 

[ZVI]

The only thing now is adjust the .LeftIndent property for each row of the table.

What is the adjusting rules for pictures and for captions?