Add Multiple Pics & Captions to a Document

victorybadges · #1 12-25-2020, 06:05 PM

Hi Paul

I have now being working with the original code in https://www.msofficeforums.com/drawi...ument-all.html and, while I have changed a number of things and can also use Word to improve the output such as centring the caption line, the one thing I cannot do is to form fit the text to fit in the prescribed column width, hope you can help.

here is my revised macro for captions

Code:

Sub AddPics()
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
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RwHght = 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
'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 ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    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 = ((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
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, 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
        '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
        oTbl.Cell(r + 1, 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)
    .Height = Hght
    .HeightRule = wdRowHeightExactly
    .Range.Style = "TblPic"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

macropod · #2 12-26-2020, 04:52 AM

I don't see where you're centring the caption, which in any event should be accomplished by modifying the Caption Style, not by overriding the paragraph format in code. Indeed, your line:

Code:

oTbl.Cell(r + 1, c).Range.Text = StrTxt

eliminates all of Word's implementation of normal captioning conventions.

To fit the text to the cell, you could use the .FitText method. See the relevant code in the link.

victorybadges · #3 12-26-2020, 02:31 PM

thank you, I have had trouble so I started off with your original macro for the captions and then placed this last change and it worked fine. However I dont want the label "Picture: ". How do I only show the file name please.

macropod · #4 12-27-2020, 01:55 PM

For just the text:

Code:

        With oTbl.Cell(r + 1, c).Range
            .Text = StrTxt
        End With

victorybadges · #5 12-27-2020, 03:16 PM

H Paul
thank you for your latest update
sorry I keep asking you questions
the caption is now fitting as requested however its squeezed against the adjacent captions. Ideally 0.1cm left and right margin or a run time selection for the margin and can you do it so the caption is centred please

thank you

macropod · #6 12-29-2020, 05:29 AM

Change:

Code:

.FitTextWidth = ColWdth

to:

Code:

.FitTextWidth = ColWdth - CentimetersToPoints(0.1)

victorybadges · #7 12-30-2020, 03:51 AM

just tested it thanks
no left indent and not centred

macropod · #8 12-30-2020, 05:30 AM

As I said in an earlier reply, changes to the caption paragraph's formatting should be done by changing the Style definition. You can do that manually, or by code. In your post previous to that, you said you had already modified things so that you were getting the required centring.

victorybadges · #9 12-30-2020, 03:26 PM

thanks Paul, sorry I had forgotten regarding centring. No code, I manually highlight the table and click on paragraph centre so that is fine,
so only thing left is the left indent please, if this is too difficult I can increase the CentimetersToPoints from 0.1 to say 0.2 and then centre it.
let me know

macropod · #10 12-31-2020, 06:33 AM

Quote:

Originally Posted by victorybadges

No code, I manually highlight the table and click on paragraph centre so that is fine

That is absolutely the wrong way to do it.

To center the captions (the pics are already centered), before:

Code:

      With .Styles("TblPic").ParagraphFormat

insert:

Code:

      .Styles("Caption").ParagraphFormat.Alignment = wdAlignParagraphCenter

It's not apparent why you'd want both centering and indenting in this situation.

victorybadges · #11 12-31-2020, 10:51 PM

perfect thanks

victorybadges · #12 02-13-2021, 10:49 PM

Dear Paul, had to revisit this as my Word updated itself and I lost my macros
I am back now where I was after a few hours of reconstructing.
The macro with the captions I still need a slight modification. For file names which seem to fit perfectly within the width of the column there appears to be no indenting, so if adjacent files names are of similar length they appear touching each other. Hope you can help.

This is my file at this stage

Code:

Sub Add_PicsinTable_with_Captions()
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
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
RwHght = 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
'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 ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      If TblWdth / NumCols < ColWdth Then ColWdth = TblWdth / NumCols
    End With
    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 = ((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
        Set iShp = ActiveDocument.InlineShapes.AddPicture( _
          FileName:=.SelectedItems(j), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, 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
        '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
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
        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"
    .Cells.VerticalAlignment = wdCellAlignVerticalCenter
  End With
  With .Rows(x + 1)
    .Height = CentimetersToPoints(0.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

macropod · #13 02-14-2021, 04:12 AM

Change this:

Code:

        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c).Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
        End With

to this:

Code:

        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          .LeftPadding = CentimetersToPoints(0.15)
          .RightPadding = CentimetersToPoints(0.15)
          With .Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = ColWdth - CentimetersToPoints(0.3)
            End If
          End With
        End With

victorybadges · #14 02-14-2021, 02:12 PM

thank you Paul, but this has revealed two issues

firstly can it centre first and then do the padding as this is more evident in small file names that there is no centring of the caption

secondly I noticed a different issue in that the images in the 2nd row onwards are not centred, I tested it several times (this does not happen with my macro with no captions ?)

regards Nick

macropod · #15 02-14-2021, 06:24 PM

Quote:

Originally Posted by victorybadges

can it centre first and then do the padding as this is more evident in small file names that there is no centring of the caption

I already showed you how to center the Caption Style in post #10.

Quote:

Originally Posted by victorybadges

the images in the 2nd row onwards are not centred, I tested it several times (this does not happen with my macro with no captions ?)

Not when you use the code I've supplied. Apparently your mods have resulted in the centering applying to the wrong rows.

My preferred approach would be to configure the entire table with a suitable amount of cell padding all round plus, of course, the centering of the Caption Style. For example:

Code:

Sub Add_PicsinTable_with_Captions()
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, RowHght As Single, ColWdth As Single
Dim HPad As Single, VPad As Single, PicHght As Single, PicWdth As Single
HPad = CentimetersToPoints(0.15):   VPad = CentimetersToPoints(0.05)
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
    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
      .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
      .AutoFitBehavior (wdAutoFitFixed)
      .TopPadding = VPad
      .BottomPadding = VPad
      .LeftPadding = HPad
      .RightPadding = HPad
      .Spacing = 0
      .Columns.Width = ColWdth
      .Borders.Enable = True
      .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
    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 = Split(Split(StrTxt, ".")(0)
        'Insert the Caption on the row below the picture
        With oTbl.Cell(r + 1, c)
          With .Range
            .Text = StrTxt
            If .Characters.Last.Previous.Information(wdVerticalPositionRelativeToPage) <> _
              .Characters.First.Information(wdVerticalPositionRelativeToPage) Then
              .FitTextWidth = PicWdth
            End If
          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.5)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Caption"
  End With
End With
End Sub

Note that I've also chosen to omit the filepaths from the captions.

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