Work Around Word’s Limitations with Image Captioning

[macropod]

When images are positioned with text wrapping 'Square', Word inserts their captions into text boxes. In such situations, the caption ordering for multiple shapes anchored to a single paragraph is hard to control because it’s based on the order of the anchors in the document stream (which you can’t see). Captions in textboxes create other problems of their own if you create a Table of Figures (TOF); in that case, Word inserts a fully-qualified path into the TOF, which creates problems when the file is saved as PDF (the TOF links back to the original document).

The following macro resolves these issues by inserting the images into the cells of floating tables, as inlineshapes, with the captions in the tables also. As coded, the macro processes all floating & inline images, but it could be stripped down to work with just the floating images or even just a selected image. Either way, the disconnect between the images and their captions will be resolved. Whatever positioning and text wrapping applied to the original image will apply to the table also.



To have the caption row appear above the image, instead of below, change the Rows(1) references to Rows(2), change the Cell(1, 1) references to Cell(2, 1) and change the change the Cell(2, 1) references to Cell(1, 1).

Note that, due to the extra space taken up by the caption row, all except for the first of the document's pictures are liable to shift position.

Once the macro has run, it will be a simple matter to move any existing captions into the empty cells provided and delete whatever paragraphs/textboxes those captions formerly occupied.

Sub AddImageCaptionTables()
Application.ScreenUpdating = False
'Sourced from: https://www.msofficeforums.com/drawing-and-graphics/49784-work-around-word-limitations-image-captioning.html
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
With ActiveDocument
  For i = 1 To .InlineShapes.Count
    If .InlineShapes(i).Range.Information(wdWithInTable) = False Then 
      With .InlineShapes(i)
        .LockAspectRatio = True
        PicWdth = .Width
        PicHght = .Height
        Set Rng = .Range
      End With
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
      BShp = False: VRel = 0: HRel = 0: VPos = 0: HPos = 0
      Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
    End If
  Next
  While .Shapes.Count > 0
    BShp = True
    With .Shapes(1) 
      .LockAspectRatio = True
      PicWdth = .Width
      PicHght = .Height
      VRel = .RelativeVerticalPosition
      HRel = .RelativeHorizontalPosition
      VPos = .Top
      HPos = .Left
      Set iShp = .ConvertToInlineShape
    End With
    With iShp
      Set Rng = .Range
      .Range.Cut
    End With
    Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
  Wend
End With
End Sub
 
Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
  VRel As Long, HRel As Long, VPos As Single, HPos As Single)
Dim Tbl As Table, sngScl As Single, iShp As InlineShape
'Constrain maximum image size
If PicWdth > CentimetersToPoints(7.5) Then
  sngScl = PicWdth / CentimetersToPoints(7.5)
  PicWdth = PicWdth / sngScl
  PicHght = PicHght / sngScl
End If
If PicHght > CentimetersToPoints(5) Then
  sngScl = PicHght / CentimetersToPoints(5)
  PicWdth = PicWdth / sngScl
  PicHght = PicHght / sngScl
End If
'Create & format the table
Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
With Tbl
  .Borders.Enable = True
  .Columns.Width = PicWdth
  .TopPadding = 0
  .BottomPadding = 0
  .LeftPadding = 0
  .RightPadding = 0
  .Spacing = 0
  .Rows(1).HeightRule = wdRowHeightExactly
  .Rows(1).Height = PicHght
  With .Rows
    .LeftIndent = 0
    If BShp = True Then
      .WrapAroundText = True
      .HorizontalPosition = HPos
      .RelativeHorizontalPosition = HRel
      .VerticalPosition = VPos
      .RelativeVerticalPosition = VRel
      .AllowOverlap = False
    End If
  End With
  With .Cell(1, 1).Range
    With .ParagraphFormat
      .SpaceBefore = 0
      .SpaceAfter = 0
      .LeftIndent = 0
      .RightIndent = 0
      .FirstLineIndent = 0
      .KeepWithNext = True
    End With
    .Paste
    'Resize the inserted InlineShape
    Set iShp = .InlineShapes(1)
    With iShp
      .Width = PicWdth
      .Height = PicHght
    End With
  End With
  'Insert the caption
  With .Cell(2, 1).Range
    .Style = "Caption"
    .End = .End - 1
    .InsertAfter vbCr
    .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:="", _
      Position:=wdCaptionPositionBelow, ExcludeLabel:=0
    .Paragraphs.First.Range.Characters.Last.Text = vbNullString
    .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Borders(wdBorderRight).LineStyle = wdLineStyleNone
    .Borders(wdBorderTop).LineStyle = wdLineStyleNone
  End With
End With
Application.ScreenUpdating = True
End Sub

To work with just the selected image (or multiple images in a selected range), change:

With ActiveDocument

to:

With Selection

and change:

  While .Shapes.Count > 0
    With .Shapes(1)

to:

  While .ShapeRange.Count > 0
    With .ShapeRange(1)

Note 1: As coded, the 'MakeImageTable' macro limits the inserted InlineShape dimesnsions to 7.5*5.0cm. That code can, of course, be edited/omitted. If it is to be omitted, so too can the corresponding code that re-sizes the inserted InlineShape to fit. The code concerned is found between 'Constrain maximum image size' and 'Create & format the table', and between 'Resize the inserted InlineShape' and 'Insert the caption', respectively.

Note 2: As coded, the 'MakeImageTable' macro inserts the word 'Figure' as the caption label for each caption. That label can be changed to something else, or that part of the code can be omitted entirely.

For PC macro installation & usage instructions, see: Installing Macros
For Mac macro installation & usage instructions, see: Word:mac - Install a Macro