Microsoft Office Forums - View Single Post - [Solved] Macro to add captions to pictures inside word document

macropod · 02-12-2014, 05:26 AM

There are two kinds of image formats one can encounter with a Word document: in-line and floating. With the in-line format, it's quite easy to insert a caption after the image and know where it will be in relation to that image. With floating shapes, however, the only way of ensuring the captions align with the images is to insert textboxes that can be positioned near the images.

In either case, the problem then becomes one of ensuring the captions and images stay together on the same page. The best way of doing this is to insert both the image and its caption into a Word table. For floating shapes, that means changing their format to in-line, but that's OK since the table can be made to float over the text in much the same way.

Compared to what's involved in the above, finding the in-line shapes and floating shapes is quite easy; instead of using Find, you loop through the InlineShape and Shape collections, respectively. For example, the following macro embeds all 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, 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
      PicWdth = .InlineShapes(i).Width
      Set Rng = .InlineShapes(i).Range
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        PicWdth = .InlineShapes(1).Width
        PicHght = .InlineShapes(1).Height
        .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)
      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
'Create & format the table
Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
With Tbl
  .Borders.Enable = False
  .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
  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
    .Paragraphs.First.Range.Characters.Last.Text = vbNullString
  End With
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.

PS: When posting code, please use the code tags. They're on the 'Go Advanced' tab.