Convert Shape in Table to InlineShape

[Steve]

I have a two-cell table (two rows, one column). I want to convert a Shape in
Cell 1 (row 1, col 1) to an inline shape. The For Each/Next block below
converts all shapes in the ActiveDocument. I want to only convert the shape
in Cell 1. How can I do this? I can't figure out the object syntax.

Thanks to Doug Robbins for helping me set up AutoText tables and do the
reformatting of the cells based on the InlineShape size (I tweaked the last
line to set the entire column width, not just the Cell 1 width).

Steve Drenker

Sub SetTableDims()
Dim oHeight As Single
Dim oWidth As Single

Dim s As Shape

For Each s In ActiveDocument.Shapes ' <--How do I fix this line to
convert shapes in selected table?
If s.Type = msoPicture Then
s.ConvertToInlineShape
End If
Next s

oHeight = Selection.Tables(1).Cell(1, 1).Range.InlineShapes(1).Height
oWidth = Selection.Tables(1).Cell(1, 1).Range.InlineShapes(1).Width

Selection.Tables(1).Cell(1, 1).Height = oHeight
Selection.Tables(1).Columns(1).Width = oWidth
End Sub

 

[Jay Freedman]

Hi Steve

Since you just want to affect one Shape in one location, there's no need for
a loop. Here's one way to do it:

Sub SetTableDims()
Dim oHeight As Single
Dim oWidth As Single
Dim s As Shape
Dim oCell As Cell

On Error GoTo Bye ' if no table or no Shape

Set oCell = Selection.Tables(1).Cell(1, 1)

Set s = oCell.Range.ShapeRange(1)

If s.Type = msoPicture Then
s.ConvertToInlineShape

oHeight = oCell.Range.InlineShapes(1).Height
oWidth = oCell.Range.InlineShapes(1).Width

oCell.Height = oHeight
Selection.Tables(1).Columns(1).Width = oWidth
End If
Bye:
End Sub

The oddity is that there is no Shapes collection for a Selection or Range,
only for the whole document. The equivalent is a ShapeRange. If you wanted
to continue to work with the Shapes collection, you could keep the For Each
s in ActiveDocument.Shapes, and use the InRange function to determine when
you've found the right shape:

Sub SetTableDims()
Dim oHeight As Single
Dim oWidth As Single
Dim s As Shape
Dim oCell As Cell

On Error GoTo Bye ' if no table

Set oCell = Selection.Tables(1).Cell(1, 1)

For Each s In ActiveDocument.Shapes
If s.Anchor.InRange(oCell.Range) Then
If s.Type = msoPicture Then
s.ConvertToInlineShape

oHeight = oCell.Range.InlineShapes(1).Height
oWidth = oCell.Range.InlineShapes(1).Width

oCell.Height = oHeight
Selection.Tables(1).Columns(1).Width = oWidth
Exit For
End If
End If
Next s
Bye:
End Sub

 

[Steve]

Thanks, Jay. Just what I needed.
Steve

Hi Steve

Since you just want to affect one Shape in one location, there's no need for
a loop. Here's one way to do it:

Sub SetTableDims()
Dim oHeight As Single
Dim oWidth As Single
Dim s As Shape
Dim oCell As Cell

On Error GoTo Bye ' if no table or no Shape

Set oCell = Selection.Tables(1).Cell(1, 1)

Set s = oCell.Range.ShapeRange(1)

If s.Type = msoPicture Then
s.ConvertToInlineShape

oHeight = oCell.Range.InlineShapes(1).Height
oWidth = oCell.Range.InlineShapes(1).Width

oCell.Height = oHeight
Selection.Tables(1).Columns(1).Width = oWidth
End If
Bye:
End Sub

The oddity is that there is no Shapes collection for a Selection or Range,
only for the whole document. The equivalent is a ShapeRange. If you wanted
to continue to work with the Shapes collection, you could keep the For Each
s in ActiveDocument.Shapes, and use the InRange function to determine when
you've found the right shape:

Sub SetTableDims()
Dim oHeight As Single
Dim oWidth As Single
Dim s As Shape
Dim oCell As Cell

On Error GoTo Bye ' if no table

Set oCell = Selection.Tables(1).Cell(1, 1)

For Each s In ActiveDocument.Shapes
If s.Anchor.InRange(oCell.Range) Then
If s.Type = msoPicture Then
s.ConvertToInlineShape

oHeight = oCell.Range.InlineShapes(1).Height
oWidth = oCell.Range.InlineShapes(1).Width

oCell.Height = oHeight
Selection.Tables(1).Columns(1).Width = oWidth
Exit For
End If
End If
Next s
Bye:
End Sub