Text Wrapping AND maintaining place with text??

Stefan Blom · #1 12-03-2015, 12:52 PM

When you add a caption to a wrapped object, Word adds the caption in a text box, which makes them a bit difficult to manage.

As an alternative, you can put the object "In line with text" and then just add the caption in the paragraph below. You can wrap a frame around the two paragraphs (for that, use the Insert Horizontal Frame command which you can add to your Quick Access Toolbar).

macropod · #2 12-03-2015, 08:51 PM

Quote:

Originally Posted by Stefan Blom

When you add a caption to a wrapped object, Word adds the caption in a text box, which makes them a bit difficult to manage.

As an alternative, you can put the object "In line with text" and then just add the caption in the paragraph below.

The approach I take is to use a table to keep the image & caption together.

The following macro embeds all Shapes & InlineShapes in a document in tables as InlineShapes with a row for Captions. Whatever positioning applied to the original Shape object will apply to the table also.

As coded, the ‘MakeImageTable’ macro limits the inserted InlineShape dimesnsions to 7.5*5.0cm. That code can, of course, be edited/omitted, in which case, so can the corresponding code that re-sizes the inserted InlineShape to fit. The macro also defaults to generating its own captions, but you can drag your own captions (Figure 1, Figure 2, etc.) into the table and replace the auto ones.

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.

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
'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
  With .Cell(2, 1).Range
    .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
    .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Borders(wdBorderRight).LineStyle = wdLineStyleNone
    .Borders(wdBorderTop).LineStyle = wdLineStyleNone
  End With
End With
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)

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).

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
editing a number/text at one place and changes taking place wherever it appears	anurag.butoliya	Word	1	06-14-2014 06:27 PM
Wrapping text On Table, Possible?	CaIeb	Word	2	08-15-2013 06:01 PM
Maintaining word format when linking text from excel	MikeFee	Office	0	06-11-2013 05:03 PM
Text Wrapping	JFS0650	Word	1	09-09-2012 11:31 AM
Text and Image Wrapping	Gonzo231	Word	1	01-03-2012 09:18 PM