Microsoft Office Forums - View Single Post - [Solved] Issue with figure captions (word 2010)

macropod · 08-15-2014, 03:18 PM

The difference in behaviour is related to the wrap format of the images. If they're in-line with text, Word is programmed to insert the captions that way too. If they're square, for example, Word is programmed to insert the captions into a textbox. IMHO, the latter is dumb, as there is no necessary connection between the caption and its image and the caption numbering becomes dependent on where the caption is anchored, and the anchor's order in the document, not on the anchor position of the image to which it relates. The treatment of inline images really isn't much better as it's all too easy to move the image without its caption.

The following macro embeds all images (i.e. Shapes & InlineShapes) in a document in tables with a row for Captions.

Code:

Sub AddImageCaptionTables()
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long
With ActiveDocument
  For i = 1 To .InlineShapes.Count
    If .InlineShapes(i).Range.Information(wdWithInTable) = False Then
      PicWdth = .InlineShapes(i).Width
      Set Rng = .InlineShapes(i).Range
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
      'If you don't want a row for captioning etc, change the 2 in the next line to 1.
      Set Tbl = .Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
      With Tbl
        With .Cell(1, 1).Range.ParagraphFormat
          .SpaceBefore = 0
          .SpaceAfter = 0
          .LeftIndent = 0
          .RightIndent = 0
          .FirstLineIndent = 0
          .KeepWithNext = True
        End With
        .Cell(1, 1).Range.Paste
        'If you don't want to add captions, delete from here to 'End With'
        Set Rng = .Cell(2, 1).Range
        With Rng
          .Style = "Caption"
          .End = .End - 1
          .InsertAfter vbCr
          .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:="", _
            Position:=wdCaptionPositionBelow, ExcludeLabel:=0
          .Characters.First.Text = vbNullString
          .Paragraphs.First.Range.Characters.Last.Text = vbNullString
        End With
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
        .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Columns.Width = PicWdth
      End With
    End If
  Next
  While .Shapes.Count > 0
    With .Shapes(1)
      VRel = .RelativeVerticalPosition
      HRel = .RelativeHorizontalPosition
      VPos = .Top
      HPos = .Left
      PicWdth = .Width
      Set iShp = .ConvertToInlineShape
    End With
    With iShp
      Set Rng = .Range
      .Range.Cut
    End With
    'If you don't want a row for captioning etc, change the 2 in the next line to 1.
    Set Tbl = .Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
    With Tbl
      With .Rows
        .LeftIndent = 0
        .WrapAroundText = True
        .HorizontalPosition = HPos
        .RelativeHorizontalPosition = HRel
        .VerticalPosition = VPos
        .RelativeVerticalPosition = VRel
        .AllowOverlap = False
      End With
      With .Cell(1, 1).Range.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LeftIndent = 0
        .RightIndent = 0
        .FirstLineIndent = 0
        .KeepWithNext = True
      End With
      .Cell(1, 1).Range.Paste
      'If you don't want to add captions, delete from here to 'End With'
      Set Rng = .Cell(2, 1).Range
      With Rng
        .Style = "Caption"
        .End = .End - 1
        .InsertAfter vbCr
        .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:="", _
          Position:=wdCaptionPositionBelow, ExcludeLabel:=0
        .Characters.First.Text = vbNullString
        .Paragraphs.First.Range.Characters.Last.Text = vbNullString
      End With
      .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
      .Borders(wdBorderRight).LineStyle = wdLineStyleNone
      .Borders(wdBorderTop).LineStyle = wdLineStyleNone
      .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
      .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
      .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
      .TopPadding = 0
      .BottomPadding = 0
      .LeftPadding = 0
      .RightPadding = 0
      .Spacing = 0
      .Columns.Width = PicWdth
    End With
  Wend
End With
End Sub

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.

As coded, the macro inserts the caption row below its image If you want them to be above the images, swap the .Cell(1, 1) and .Cell(2, 1) references around (i.e. all .Cell(1, 1) references become .Cell(2, 1) and vice-versa).