Add Multiple Pics & Captions to a Document

victorybadges · #31 06-03-2025, 12:10 AM

StrTxt = ": " & Left(StrTxt, InStrRev(StrTxt, "."))
this was producing ":" prefix so I removed it
sorry I am learning as I go, what is a code tag

macropod · #32 06-03-2025, 12:13 AM

Well that's in the code because there's supposed to be a colon after the Caption word...
Code tags are inserted via the # on the toolbar. You post your code between them.

victorybadges · #33 06-03-2025, 12:18 AM

Code:

Sub Add_PicsinTable_with_Captions()
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, RowHght As Single, ColWdth As Single
Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single
HPad = CentimetersToPoints(0#):     VPad = CentimetersToPoints(0#)
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RowHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?")))
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
PicHght = RowHght - VPad * 2: PicWdth = ColWdth - HPad * 2
'MsgBox "PicWdth: " & PointsToCentimeters(PicWdth) & vbTab & "ColWdth: " & PointsToCentimeters(ColWdth)
'MsgBox "PicHght: " & PointsToCentimeters(PicHght) & vbTab & "RowHght: " & PointsToCentimeters(RowHght)
'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
      .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
    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
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .Rows.Alignment = wdAlignRowCenter
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = VPad
      .BottomPadding = VPad
      .LeftPadding = HPad
      .RightPadding = HPad
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
    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, RowHght)
      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, c).Range)
        With iShp
          .LockAspectRatio = True
          If .Width < PicWdth Then .Width = PicWdth
          If .Height > PicHght Then .Height = PicHght
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = Left(StrTxt, InStrRev(StrTxt, "."))
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          With .Range
            .Text = StrTxt
                 End With
        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 = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0#)
    .HeightRule = wdRowHeightAtLeast
    .Range.Style = "Caption"
    End With
End With
End Sub

this is still producing an ending "." in the caption name
also I would like the image to be Bottom and the Caption to be Top of their respective rows please

macropod · #34 06-03-2025, 12:23 AM

Replace:

Code:

StrTxt = ": " & Left(StrTxt, InStrRev(StrTxt, "."))

with:

Code:

StrTxt = ": " & Left(StrTxt, InStrRev(StrTxt, ".") - 1)

victorybadges · #35 06-03-2025, 12:40 AM

that worked perfectly
my last issue is the alignment of the image and caption please

macropod · #36 06-03-2025, 01:05 AM

You have put the vertical alignment code in the wrong place. You don't need:

Code:

      .Range.Cells.VerticalAlignment = wdCellAlignVerticalTop

Instead of having it where you've put it, you should be using something like:

Code:

Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
  With .Rows(x)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightAtLeast
    .Range.Style = "Caption"
    .Cells.VerticalAlignment = wdCellAlignVerticalTop
  End With
End With

Except for the new line & wdRowHeightAtLeast, that's what the code in post #1 had...

victorybadges · #37 06-03-2025, 03:00 AM

Code:

Sub Add_PicsinTable_with_Captions()
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, RowHght As Single, ColWdth As Single
Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single
HPad = CentimetersToPoints(0#):     VPad = CentimetersToPoints(0#)
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RowHght = CentimetersToPoints(CSng(InputBox("What max row height for the pictures, in Centimeters (e.g. 5)?")))
ColWdth = CentimetersToPoints(CSng(InputBox("What max column width for the pictures, in Centimeters (e.g. 5)?")))
On Error GoTo 0
PicHght = RowHght - VPad * 2: PicWdth = ColWdth - HPad * 2
'MsgBox "PicWdth: " & PointsToCentimeters(PicWdth) & vbTab & "ColWdth: " & PointsToCentimeters(ColWdth)
'MsgBox "PicHght: " & PointsToCentimeters(PicHght) & vbTab & "RowHght: " & PointsToCentimeters(RowHght)
'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
      .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter
    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
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    With oTbl
      .Rows.Alignment = wdAlignRowCenter
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = VPad
      .BottomPadding = VPad
      .LeftPadding = HPad
      .RightPadding = HPad
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalTop
    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, RowHght)
      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, c).Range)
        With iShp
          .LockAspectRatio = True
          If .Width < PicWdth Then .Width = PicWdth
          If .Height > PicHght Then .Height = PicHght
        End With
        'Get the Image name for the Caption
        StrTxt = Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\")))
        StrTxt = Left(StrTxt, InStrRev(StrTxt, ".") - 1)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          With .Range
            .Text = StrTxt
                 End With
        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 = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0#)
    .HeightRule = wdRowHeightAtLeast
    .Range.Style = "Caption"
    End With
End With
End Sub

macropod · #38 06-03-2025, 03:05 AM

I can't see the point of you posting code that doesn't have the suggested changes.

victorybadges · #39 06-03-2025, 03:12 AM

I cannot see where I would place your last instruction, I have attached my macro as it stands currently

macropod · #40 06-03-2025, 03:15 AM

All you need to is delete:

Code:

      .Range.Cells.VerticalAlignment = wdCellAlignVerticalTop

and replace the FormatRows sub with the one in post #36.

victorybadges · #41 06-03-2025, 03:29 AM

ok its almost there, sorry to keep asking you.
but now while I can see the wrapping of the caption is working unfortunately the row height is not increasing automatically
I know the wrapping is working as I manually expand the caption row to see the wrapping

macropod · #42 06-03-2025, 03:39 AM

You can change:
wdRowHeightExactly
to:
wdRowHeightAtLeast
(see edited previous post) but this could result in different caption rows having different heights, or you could just change the row height (e.g. to 1cm) so all caption rows have the same height.

victorybadges · #43 06-03-2025, 03:42 AM

thank you, I don't mind different row heights, however I just tried wdRowHeightAtLeast and it did not work

macropod · #44 06-03-2025, 03:48 AM

Works for me...

victorybadges · #45 06-03-2025, 03:54 AM

oh, can you send me your full code please

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro for Inserting Multiple Photos from Excel List into Word	henhelm	Word VBA	15	02-07-2023 05:35 PM
Macro for Inserting Multiple Photos into Word but retrieving Captions from Excel Sheet	macaronipasta	Word VBA	2	06-27-2021 06:28 PM
I need a macro to automatically insert 4 pics per page in a word document with "Photograph No 1, 2,"	NewbieLearning	Word VBA	15	11-14-2017 05:03 AM
Captions: Changing captions in Appendix update all captions	carnestw	Word	3	10-27-2015 12:34 PM
How do I type on multiple pics?	TimHudson	Drawing and Graphics	0	07-28-2011 10:28 AM