Test if the active cell contains a shape

[Frank & Pam Hayes]

The code below will insert an oval into the active cell. Any pointers on
how I could later test to see if a cell contains one or multiple shape
objects and then perform some action based on the result? Something along
the lines of:

' for each Shape in ActiveCell
' if shape = msoshapeoval then
' doOvalRoutine
' else
' if shape = msoshapediamond then
' doDiamondRoutine
' end if
' end if
' next


Option Explicit

Sub MakeOval()
' Based on work by Steve Conary and others

Dim myLeft, myTop, myHeight, myWidth, myOffset

If ActiveCell.Cells.Width > ActiveCell.Cells.Height Then
myOffset = ActiveCell.Cells.Width * 0.05
Else
myOffset = ActiveCell.Cells.Height * 0.05
End If
myLeft = ActiveCell.Cells.Left + myOffset
myTop = ActiveCell.Cells.Top + myOffset
myHeight = ActiveCell.Cells.Height - 2 * myOffset
myWidth = ActiveCell.Cells.Width - 2 * myOffset
ActiveSheet.Shapes.AddShape(msoShapeOval, myLeft, myTop, myWidth,
myHeight). _
Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.Weight = 1
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Fill.Visible = msoFalse

End Sub

Thanks,

Frank Hayes

 

[Norman Jones]

Hi Frank,

Try something like:

Sub TestA()
Dim shp As Shape
Dim rng As Range

Set rng = ActiveCell

For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = rng.Address Then
If shp.AutoShapeType = msoShapeOval Then
MsgBox "Oval"
' doOvalRoutine
ElseIf shp.AutoShapeType = msoShapeDiamond Then
MsgBox "Diamond"
' doDiamondRoutine
End If
End If
Next

End Sub

 

[Frank & Pam Hayes]

Works like a charm ...

Thank you Norman

Hi Frank,

Try something like:

Sub TestA()
Dim shp As Shape
Dim rng As Range

Set rng = ActiveCell

For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = rng.Address Then
If shp.AutoShapeType = msoShapeOval Then
MsgBox "Oval"
' doOvalRoutine
ElseIf shp.AutoShapeType = msoShapeDiamond Then
MsgBox "Diamond"
' doDiamondRoutine
End If
End If
Next

End Sub