jar-_-
06-24-2023, 07:28 AM
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.
3089330894
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
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
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
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.
3089330894
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
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
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