Lets say you’ve created caption for all your images, but then you decide to move the image to a new location. The caption will not follow and you will end up with something that looks like this:

In this article I will explain how you can re-adjust image caption using VBA for word.

As explained in the article Word VBA, Removing Picture Captions, depending on whether the image is floating or inline, image captions will wither be:

1. A text box
2. Regular text

and therefore would require 2 different approaches for readjusting.

Re-adjusting Floating Image Caption:

As mentioned in the article below, the caption for floating images is basically a text box:

• Word VBA, Removing Picture Captions

Therefore in order to re-adjust the caption for floating images in a document we would require a macro that would do the following things:

1. Loop through all the shapes in the document
2. Check if each shape is a text box or not
3. Check the first 6 characters in the text box. If it is “Figure” then that text box is probably a caption
4. Using String Processing, get the text associated with that caption. Note we only need the part after “Figure X”, where “X” is the caption index.
5. Store the text associated with the caption in an array
6. Delete all captions
7. Create captions for all images using the text stored in the array

Sub Example()
'number of shapes in document
Dim intCount As Integer
Dim i As Integer
'number of deleted captions
Dim intDeleted As Integer
'the text in the caption
Dim strText As String
'stores the caption text
Dim arrCaptionText() As String
intCount = Shapes.Count
intDeleted = 0
ReDim arrCaptionText(1 To 1)
'loops through all the shapes in the document
For i = 1 To intCount
    'checks if the current shape is a text box
    If Shapes.Item(i - intDeleted).Type = _
    msoTextBox Then
        Shapes.Item(i - intDeleted).Select
        'gets the text in the text box
        strText = Selection.Range
        'checks if the text box is a caption
        If Strings.Left(strText, 6) = "Figure" Then
           Call GetText(arrCaptionText, strText)
           'removes the text box
           Shapes.Item(i - intDeleted).Delete
           'increments the variable
           intDeleted = intDeleted + 1
        End If
    End If
Next i

ReDim Preserve arrCaptionText(1 To Shapes.Count)
'loop through shapes
For i = 1 To Shapes.Count
    'check if the current shape is a picture
    If Shapes.Item(i).Type = _
        msoPicture Then
        'select the picture
        Shapes.Item(i).Select
        'assign a caption to it
        Selection.InsertCaption Label:="Figure", _
        Title:=arrCaptionText(i), _
        Position:=wdCaptionPositionBelow
    End If
Next i
End Sub 

'removes the numeric part from the caption text
Private Sub GetText(ByRef arrCaptionText() As String, _
ByVal strText As String)
     
Dim flag As Boolean
'the numeric part of the caption text
Dim strNumber As String
'a number
Dim strChar As String
'remove the "figure " from the caption
strText = Strings.Right(strText, Strings.Len( _
    strText) - 7)
flag = True
strNumber = ""
'keeps going until the number is removed
While flag = True
    'a digit from the digit
    strChar = Strings.Left(strText, 1)
    'checks if its a number
    If IsNumeric(strChar) = True Then
        'adds it to strNumber
        strNumber = strNumber + Strings.Left(strText, _
            1)
        'removes it from the caption text
        strText = Strings.Right(strText, _
           Strings.Len(strText) - 1)
    'adds the text to the array
    ElseIf UBound(arrCaptionText) > Int(strNumber) Then
        arrCaptionText(Int(strNumber)) = _
           strText
        flag = False
    Else
        'resizes the array and adds the number to it
        ReDim Preserve arrCaptionText(1 To Int(strNumber))
        arrCaptionText(Int(strNumber)) = _
           strText
        flag = False
    End If
Wend
End Sub


Result:

The array below was used to store the caption text values:

Dim arrCaptionText() As String


The first for i loop, literates through the shapes in the document, and looks for text boxes:

For i = 1 To intCount
    'checks if the current shape is a text box
    If Shapes.Item(i - intDeleted).Type = _
    msoTextBox Then
...
    End If
Next i


Based on the first 6 characters in the text box it determines whether the text box is a caption or not:

Shapes.Item(i - intDeleted).Select
'gets the text in the text box
strText = Selection.Range
'checks if the text box is a caption
If Strings.Left(strText, 6) = "Figure" Then
...
End If


The function below uses string processing to separate the “Figure x” part from the caption text. Based on the number “x” it determines which index to store the text in:

Call GetText(arrCaptionText, strText)


For more information about string processing please see the link below:

• Excel VBA, String Processing and Manipulation

Although the article was written for Excel, the topics can be used in VBA for Word.

Inline Images:

For inline images we will need a macro similar to the macro used in the article below:

• Word VBA, Removing Picture Captions

As mentioned in that article caption for inline images is regular text. Inside the caption there is a field with the following code:

" SEQ Figure *"


We require a macro to do the following:

1. Search through all the fields in the document
2. Check the code for each field to see if it matches with the one above
3. Store the text after the field in an array
4. Repeat steps 1 and 2
5. Delete the entire line
6. Loop through all the InlineShapes in the document
7. If the inline shape is an image add a caption to it with the text from the array

This is done by the code below:

Sub Example()
Dim i As Integer
Dim strField As String
Dim intDeleted As Integer
Dim arrText() As String

ReDim Preserve arrText(1 To 1)
'loop through all the fields
For i = 1 To Fields.Count
    'get the field code
    strField = Fields.Item(i).Code
    'check the field code
    If Strings.Left(strField, 14) = _
        " SEQ Figure *" Then
        'select the field
        Fields.Item(i).Select
        Selection.MoveRight Unit:=wdCharacter, Count:=1
        Selection.EndKey Unit:=wdLine, _
           Extend:=wdExtend
        'delete it
        If i > UBound(arrText) Then
           ReDim Preserve arrText(1 To i)
           arrText(i) = Selection.Range.Text
        End If
    End If
Next i

'loop through all the fields
For i = 1 To Fields.Count
    'get the field code
    strField = Fields.Item(i - intDeleted).Code
    'check the field code
    If Strings.Left(strField, 14) = _
        " SEQ Figure *" Then
        'select the field
        Fields.Item(i - intDeleted).Select
        Selection.HomeKey Unit:=wdLine
        Selection.EndKey Unit:=wdLine, _
           Extend:=wdExtend
        'delete it
        Selection.Delete
        intDeleted = intDeleted + 1
    End If
Next i

'loop through inline shapes
For i = 1 To InlineShapes.Count
    'check if the current shape is a picture
    If InlineShapes.Item(i).Type = _
        wdInlineShapePicture Then
        'select the picture
        InlineShapes.Item(i).Select
        'assign a caption to it
        Selection.InsertCaption Label:="Figure", _
           Title:=arrText(i), _
           Position:=wdCaptionPositionBelow
    End If
Next i
End Sub


1. The first for i loop, loops through all the fields in the document. If the field is a caption it will store its text in the array arrText.
2. The second for i loop, loops through all the fields in the document. If the field is a caption it will delete it.
3. The third for i loop, loops through all the InlineShapes in the document. If the shape is a picture it will add a caption to it with the text from the array arrText.

You can download the files and code related to this article from the links below:

• Re-Adjust Caption For Floating Images.docm
• Re-Adjust Caption For Inline Images.docm

See also:

• Word VBA, Get Picture Horizontal Position
• Word VBA, Loop Through Images
• Word VBA, Adding Caption to Images
• Word VBA, Removing Picture Captions

If you need assistance with your code, or you are looking for a VBA programmer to hire feel free to contact me. Also please visit my website  www.software-solutions-online.com