Macro to insert captions that after images in a table

Hello,

Can someone help me with the Sub InsertImagesWithCaptions?

The code looks for a table, called VideoStills then the user is prompted to select a folder of images. The macro will then insert the images into a table adding rows as necessary.

The code also inserts an added row below the images, which is meant for the captions that are referenced properly such that I can update the TOC if needed to include the figures.


But the code is not placing the captions below the images, instead its placing the captions at the bottom and outside the table at the end.

Images below of what I want to achieve vs what I get.

I'm able to get non cross referenced text to be added in below the images, but I need the referenced figures to update the TOC.
Attachment 30893Attachment 30894

Code:

---

Sub InsertImagesWithCaptions()    Dim imgFolder As String
    Dim imgPath As String
    Dim imgName As String
    Dim doc As Document
    Dim tbl As table
    Dim imagesCount As Integer
    Dim figuresPerRow As Integer
    Dim currRow As Row
    Dim currCell As cell
    Dim nextFigure As Integer
    Dim captionTbl As table
   
    ' Prompt user to select folder
    With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder with Images"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "No folder selected. Macro will exit.", vbExclamation
            Exit Sub
        End If
        imgFolder = .SelectedItems(1)
    End With
   
    ' Set the active document
    Set doc = ActiveDocument
   
    ' Set the table to insert images based on the alternate text (right-click on table and view table properties -> Alt Text)
    Set tbl = getTable("VideoStills")
    figuresPerRow = tbl.Columns.Count
   
    ' Set the table for captions
    Set captionTbl = getTable("VideoStills")
   
    ' Loop through images in the selected folder
    imgPath = imgFolder & Application.PathSeparator
    imgName = Dir(imgPath & "*.*")
    imagesCount = 0
   
    ' Retrieve the next figure number from the document
    nextFigure = GetNextFigureNumber(doc, "Figure ")
   
    ' Find the first empty cell in the table
    Dim rowIndex As Integer
    Dim colIndex As Integer
    rowIndex = 2
    colIndex = 1
   
    While imgName <> ""
        ' Check if a new row needs to be added for images and captions
        If rowIndex > tbl.Rows.Count Then
            tbl.Rows.Add
            captionTbl.Rows.Add
        End If
               
        ' Insert caption and store the generated range for the image
        Set captionRange = captionTbl.cell(rowIndex, colIndex).Range
        captionRange.InsertCaption Label:="Figure", Title:=": " & Left(imgName, InStrRev(imgName, ".") - 1), Position:=wdCaptionPositionBelow, ExcludeLabel:=0
       
        ' Import image into Word
        Dim imgShape As InlineShape
        Set imgShape = doc.InlineShapes.AddPicture(FileName:=imgPath & imgName, LinkToFile:=False, SaveWithDocument:=True, Range:=tbl.cell(rowIndex, colIndex).Range)
       
        ' Resize the image to the desired width and height
        imgShape.LockAspectRatio = msoFalse ' Unlock aspect ratio
        imgShape.width = InchesToPoints(3.13) ' Set the desired width in inches
        imgShape.height = InchesToPoints(2.35) ' Set the desired height in inches
       
        ' Count the images
        imagesCount = imagesCount + 1
       
        ' Move to the next cell
        colIndex = colIndex + 1
        If colIndex > figuresPerRow Then
            rowIndex = rowIndex + 2
            colIndex = 1
        End If
       
        ' Move to the next image
        imgName = Dir()
    Wend
   
    MsgBox imagesCount & " image(s) imported successfully.", vbInformation
End Sub

---

Code:

---

Function GetNextFigureNumber(doc As Document, prefix As String) As Integer    Dim rng As Range
    Set rng = doc.Content
   
    ' Set the starting figure number
    Dim startFigure As Integer
    startFigure = 1 ' Set the default starting figure number
   
    ' Search for the last figure number in the document
    With rng.Find
        .Text = prefix & "[0-9]{1,}"
        .Forward = False
        .MatchWildcards = True
        If .Execute Then
            Dim lastFigure As Integer
            lastFigure = CInt(Mid(rng.Text, Len(prefix) + 1))
            startFigure = lastFigure + 1
        End If
    End With
   
    GetNextFigureNumber = startFigure
End Function

---

Code:

---

Public Function getTable(s As String) As table
'Alt text reference
'https://stackoverflow.com/questions/63463443/can-we-access-a-word-table-by-its-name-and-not-index-using-vba


Dim tbl As table
For Each tbl In ActiveDocument.Tables
If tbl.Title = s Then
  Set getTable = tbl
  Exit Function
End If
Next
End Function

---

I solved it by incorportating snippets of this code
'vbaexpress dot com/forum/showthread.php?67081-Add-Pictures-to-Table&highlight=insert+caption

Code:

---

Sub ImportImagesWithCaptions()    Dim imgFolder As String
    Dim imgPath As String
    Dim imgName As String
    Dim doc As Document
    Dim tbl As table
    Dim imagesCount As Integer
    Dim figuresPerRow As Integer
    Dim currRow As Row
    Dim currCell As cell
    Dim nextFigure As Integer
    Dim captionTbl As table
   
    ' Prompt user to select folder
    With Application.fileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder with Images"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "No folder selected. Macro will exit.", vbExclamation
            Exit Sub
        End If
        imgFolder = .SelectedItems(1)
    End With
   
    ' Set the active document
    Set doc = ActiveDocument
   
    ' Set the table to insert images based on the alternate text (right-click on table and view table properties -> Alt Text)
    Set tbl = getTable("VideoStills") ' Function name to getTable
    figuresPerRow = tbl.Columns.Count
   
    ' Set the table for captions
    Set captionTbl = getTable("VideoStills") ' function name to getTable
   
    ' Loop through images in the selected folder
    imgPath = imgFolder & Application.PathSeparator
    imgName = Dir(imgPath & "*.*")
    imagesCount = 0
   
    ' Retrieve the next figure number from the document
    nextFigure = GetNextFigureNumber(doc, "Figure ")
   
    ' Find the first empty cell in the table
    Dim rowIndex As Integer
    Dim colIndex As Integer
    rowIndex = 2
    colIndex = 1
   
    Dim NumCols As Integer ' Number of columns per row
    NumCols = figuresPerRow ' Set it based on the table's column count
   
    ' Variables for formatting rows and inserting images
    Dim i As Integer, r As Integer, c As Integer, j As Integer
    Dim oTbl As table
    Dim RwHght As Single, ColWdth As Single
    Dim iShp As InlineShape
    Dim StrTxt As String
   
    ' Assign the table for image insertion and formatting
    Set oTbl = tbl
    ' Set the row height and column width for image resizing
    RwHght = InchesToPoints(2.35) ' Set the desired height in inches
    ColWdth = InchesToPoints(3.13) ' Set the desired width in inches
   
    While imgName <> ""
        ' Check if a new row needs to be added for images and captions
        If rowIndex > tbl.Rows.Count Then
            tbl.Rows.Add
            captionTbl.Rows.Add
        End If
       
        ' Import image into Word
        Set iShp = doc.InlineShapes.AddPicture(FileName:=imgPath & imgName, LinkToFile:=False, SaveWithDocument:=True, Range:=tbl.cell(rowIndex, colIndex).Range)
       
        ' Resize the image to the desired width and height
        iShp.LockAspectRatio = msoFalse ' Unlock aspect ratio
        iShp.width = ColWdth
        iShp.height = RwHght
       
        ' Insert caption below the image
        StrTxt = ": " & Left(imgName, InStrRev(imgName, ".") - 1)
        With captionTbl.cell(rowIndex + 1, colIndex).Range
            .InsertBefore vbCr
            .Characters.First.InsertCaption Label:="Figure", Title:=StrTxt, Position:=wdCaptionPositionBelow, ExcludeLabel:=0
            .Characters.First = vbNullString
            .Characters.Last.Previous = vbNullString
        End With
       
        ' Count the images
        imagesCount = imagesCount + 1
       
        ' Move to the next cell
        colIndex = colIndex + 1
        If colIndex > figuresPerRow Then
            rowIndex = rowIndex + 2
            colIndex = 1
        End If
       
        ' Move to the next image
        imgName = Dir()
    Wend
   
    MsgBox imagesCount & " image(s) imported successfully.", vbInformation
End Sub

---

Code:

---




Function GetNextFigureNumber(doc As Document, prefix As String) As Integer
    Dim rng As Range
    Set rng = doc.Content
   
    ' Set the starting figure number
    Dim startFigure As Integer
    startFigure = 1 ' Set the default starting figure number
   
    ' Search for the last figure number in the document
    With rng.Find
        .Text = prefix & "[0-9]{1,}"
        .Forward = False
        .MatchWildcards = True
        If .Execute Then
            Dim lastFigure As Integer
            lastFigure = CInt(Mid(rng.Text, Len(prefix) + 1))
            startFigure = lastFigure + 1
        End If
    End With
   
    GetNextFigureNumber = startFigure
End Function

---

Code:

---


Public Function getTable(s As String) As table
'Alt text reference
'https://stackoverflow.com/questions/63463443/can-we-access-a-word-table-by-its-name-and-not-index-using-vba


Dim tbl As table
For Each tbl In ActiveDocument.Tables
If tbl.Title = s Then
  Set getTable = tbl
  Exit Function
End If
Next
End Function

---

Thanks for telling how you solved the issue and for marking the thread [SOLVED]