Import images to word with caption text.

[thijmen2256]

Hello everyone!,

I am running into an issue I can't seem to figure out in word.
I try to import several images at the same time along with their captions, I am quite unexperienced with code so to do this I found code online.
Sadly I cant figure out how to alter the code to put the caption text on the right next to the image instead of beneath it.

Attached is the code and some images to make clear what I'm working on.

I think the solution is to alter the 'insert the captop on the row below the picture' oTbl.Cell(r + 1, c).Range.Text = StrTxt
And to alter this so that it doesnt go below but to the right of the image, cant seem to get it to work though.

If anyone has knowledge on this and can offer a solution and maybe a bit of an explaination as to how it works, I'd be more then greatfull to you.

Thanks in advance!

Schermafbeelding 2023-04-24 112727.png

Schermafbeelding 2023-04-24 112633.png

Schermafbeelding 2023-04-24 112700.png

[HansV]

You didn't attach anything.

By the way, you haven't responded to the replies that you received to your first question Re: VBA : Export Shape/Image/Object As Picture (.PNG Fomat)

[thijmen2256]

My apologies, I remember sending a thank you and a message that the problem is solved on the last post.
I do see that it didn't come through so I placed a new one!

For the images I will try to attach them again, not sure why they didnt come through.

[HansV]

Thanks. Could you copy/paste the code itself into a reply?

[thijmen2256]

Code: Select all

Sub AddPics()
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, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
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
    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
    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
      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(Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))), ".")(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(2)
    .HeightRule = wdRowHeightExactly
    .Range.Style = "Titel"
  End With
End With
End Sub

[HansV]

Thanks, that is helpful.
Do you want to insert the captions into the cells with the images, or into separate cells to the right of each image?

[thijmen2256]

If there was a way to insert the captions into the cells with the images on the right side of the images that would be perfect.

[HansV]

I'll have a look after dinner.

[HansV]

I have been experimenting with the code. Getting the pictures and filenames into the same cell is a nightmare if the images have different sizes. In that situation, I'd place the filenames in a separate cell to the right of the image cell. Code could look like this:

Code: Select all

Sub AddPics()
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, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
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
    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
    End With
    'Add a 1-row by 2* NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=2 * NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      ColWdth = TblWdth / (2 * 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
      '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, 2 * c - 1).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(Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))), ".")(0)
        'Insert the Caption on the row below the picture
        oTbl.Cell(r, 2 * 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
      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
End With
End Sub

See the next reply for an alternative - stay tuned.

[HansV]

Here is a version that should work if all images are (more or less) square. It places the text in the same cell as the image.

Code: Select all

Sub AddPics()
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, RwHght As Single, ColWdth As Single
On Error GoTo ErrExit
NumCols = CLng(InputBox("How Many Columns per Row?"))
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
    On Error Resume Next
    With ActiveDocument
      .Styles.Add Name:="TblPic", Type:=wdStyleTypeParagraph
      On Error GoTo 0
      With .Styles("TblPic").ParagraphFormat
        .Alignment = wdAlignParagraphLeft
        .KeepWithNext = True
        .SpaceAfter = 0
        .SpaceBefore = 0
      End With
    End With
    'Add a 1-row by NumCols-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=NumCols)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
      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
      '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
          .Width = ColWdth / 2
        End With
        'Get the Image name for the Caption
        StrTxt = Split(Split(.SelectedItems(j), "\")(UBound(Split(.SelectedItems(j), "\"))), ".")(0)
        'Insert the Caption on the row below the picture
        oTbl.Cell(r, c).Range.InsertAfter 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
      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
End With
End Sub