Test if the active cell contains a shape
 

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

Test if the active cell contains a shape
 

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



---
Regards,
Norman



"Frank & Pam Hayes" wrote in message
news:7qUUe.2933$XO6.431@trnddc03...
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

Test if the active cell contains a shape
 

Works like a charm ...

Thank you Norman


"Norman Jones" wrote in message
...
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



---
Regards,
Norman



"Frank & Pam Hayes" wrote in message
news:7qUUe.2933$XO6.431@trnddc03...
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