Shapes.AddPicture in Word Table - vba

Question

I am using a Word table as a placeholder for images, where table cells contain only pictures and no text.
When inserting a picture into a Word table, I have no problems when inserting an Inline Shape. The picture appears into the expected cell. However, with the "equivalent" code which inserts the picture as a Shape, the shape does not always appear in the expected cell. So far, I have seen this problem in Word 2013, 32 bit version.
Sub test()
Dim s As Shape
Dim x As String
Dim f As String
Dim r As Long
Dim c As Long
Dim h As Single
Dim w As Single
Dim rng As Word.Range
Dim ins As Word.InlineShape
f = "file name of a picture, .bmp .jpg etc."
Word.Application.ScreenUpdating = False
If Selection.Information(wdWithInTable) Then
' insert a picture in a table cell
r = Selection.Information(wdStartOfRangeRowNumber)
c = Selection.Information(wdStartOfRangeColumnNumber)
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
' Works reliably
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
s.height = h
s.width = w
' Not at all reliable
' Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
Else
' insert a picture at the cursor
h = 100
w = 100
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h)
End If
Word.Application.ScreenUpdating = True
s.WrapFormat.Type = wdWrapInline
s.Title = "Title"
s.AlternativeText = "Some metadata"
End Sub
The idea is to select either a cell in a table in a document or somewhere on the page outside of the table. The outside of the table case works as expected where the picture appears at the cursor location.
To see the problem, start with a fresh document, single page, add a 3 x 3 table and deepen the rows a bit. Be sure to supply a file to insert, variable f. Select one of the cells, then run the code. This works correctly when the picture is inserted as an inline shape then immediately converted to a shape. That happens with this line:
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
However, the preferred solution would be to insert a Shape from the beginning with code something like this:
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
The picture appears, but usually not in the expected location. It could be placed into a different cell or somewhere outside the table.
Is the rng argument to Shapes.AddPicture being ignored or mangled somehow?
Experimenting some more with the 3 x 3 table - adding pictures then setting every possible WrapFormat.Type (there are 8 possible values), I see that:
for every WrapFormat.Type except wdWrapInLine, picture insertion works correctly as long as they are done from left to right on a table row, and;
for every WrapFormat.Type without exception, when the row is initially empty, pictures inserted in columns 2 or 3 appear one column to the left.
Making the picture smaller, such as setting h = .height * 0.5 and w = .width * 0.5, has no effect on placement.
Thanks very much for any insight or elucidation.

Answer 1

The main problem appears to be about the pictures inserting in the wrong column. This would be because the "focus point" (location of the Range) of an empty table cell has its starting point in the previous cell. Doesn't really make a lot of sense, but that's how Word works...
Try collapsing the Range to the End, rather than the Start (wdCollapseEnd) in this extract from your code:
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseEnd 'instead of wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With

Answer 2

In the end, selective usage of rng.collapse did the trick. I have yet to check whether this behaviour is the same in Word 2010 or 2016.
For the first shape anywhere in a table row, rng.collapse wdCollapseEnd.
For all subsequent shapes on that table row, rng.collapse wdCollapseBegin.
I used the following code to count up the shapes in table rows:
Dim numShapes() As Integer
Dim cel As Word.cell
ReDim numShapes(1 To Selection.Tables(1).Rows.Count)
For Each cel In Selection.Tables(1).Range.Cells
If cel.Range.ShapeRange.Count <> 0 Then
numShapes(cel.RowIndex) = numShapes(cel.RowIndex) + 1
End If
Next cel
and the check is simply
If numShapes(r) <> 0 Then
rng.collapse wdCollapseStart
Else
rng.collapse wdCollapseEnd
End If
where r is the row number from the first code example.
Initial experiments with merged cells suggest other problems...