[SOLVED] 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



---
Regards,
Norman



"Frank & Pam Hayes" <[email protected]> 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
>

[Frank & Pam Hayes]

Works like a charm ...

Thank you Norman


"Norman Jones" <[email protected]> wrote in message
news:[email protected]...
> 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" <[email protected]> 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
>>
>
>