Macro to create tables around all images in document

lsmcal1984 · #1 11-29-2013, 06:35 AM

Dear all,

I have a long document that has pictures placed throughout it.

Is it possible to write a macro that will create a table around each picture, with a caption row?

So the first row would be for a caption and the second row would contain the image.

This table would be borderless.

Many thanks!

macropod · #2 11-29-2013, 07:10 PM

Yes, it's possible but, if your pictures have text-wrapping applied (i.e. they're not formatted as in-line with text), matching the positioning on the page would require significantly more code, as would accommodating both wrapped and in-line pictures.

lsmcal1984 · #3 11-30-2013, 02:57 AM

Luckily they have been inserted with text-wrapping! How would I accomplish this?
Many thanks!

macropod · #4 11-30-2013, 04:40 AM

I'm glad you're happy but, as I said, if your pictures are not formatted as in-line with text, matching the positioning on the page will require significantly more code. It'll take me a day or so before I can get back to this.

macropod · #5 12-01-2013, 06:58 PM

Try:

Code:

Sub AddImageCaptionTables()
Dim Shp As Shape, iShp As InlineShape, Rng As Range, Tbl As Table
Dim PicWdth As Single, VPos As Single, HPos As Single, VRel As Long, HRel As Long
With ActiveDocument
  For Each Shp In .Shapes
    With Shp
      VRel = .RelativeVerticalPosition
      HRel = .RelativeHorizontalPosition
      VPos = .Top
      HPos = .Left
      PicWdth = .Width
      Set iShp = .ConvertToInlineShape
    End With
    With iShp
      Set Rng = .Range
      .Range.Cut
    End With
    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
        .DistanceTop = 0
        .DistanceBottom = 0
        .DistanceLeft = 0
        .DistanceRight = 0
        .AllowOverlap = False
      End With
      With .Cell(1, 1).Range.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LeftIndent = 0
        .RightIndent = 0
        .FirstLineIndent = 0
      End With
      .Cell(1, 1).Range.Paste
      .Cell(2, 1).Range.Style = "Caption"
      .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
  Next
End With
End Sub

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to create new word doc and save the file using String found in the document	VBNation	Word VBA	2	02-08-2013 07:14 AM
How to create an Excel add in that will automatically build tables from data	selvamariappan	Excel Programming	1	12-12-2011 03:11 AM
editing of images, tables and caption in the whole document.	Jamal NUMAN	Word	4	07-08-2011 04:14 AM
How to control the distance above tables as we do for images?	Jamal NUMAN	Word	2	07-08-2011 04:09 AM
Help with using tables to create text.	mh11	Word Tables	0	11-15-2009 10:40 AM