Add and delete pictures and shapes

[jlclyde]

I have a worksheet that I have validation/list values in. When the
operator pulls down to one of the choices "Thumbs Up", "Caution", or
"Bomb!" On workbook change event to copy a picture and put it in a
certain cell. There is also the option of blank. when the operator
hits this I would like the selection to clear of pictures. Here is my
event change code. the Test in the last Elseif statment refers to the
macro that is under this one. If I run Test by itself it works for
the selection, but if I run it through the change event it errors out
on the set Rng line. any ideas or thoughts on how to do this better?

Thanks,
Jay

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Application.ScreenUpdating = False
If Target.Column = 7 Then
If Target.Value = "Thumbs Up" Then
Sheet1.Shapes("Picture 5").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -6
ElseIf Target.Value = "Caution" Then
Sheet1.Shapes("Picture 3").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop -35
Selection.ShapeRange.IncrementLeft -15
ElseIf Target.Value = "BOMB!" Then
Target.Offset(0, -1).Select
Sheet1.Shapes("TheBomb").Copy
ActiveSheet.Paste
Selection.Name = "TheBomb"
Selection.ShapeRange.IncrementLeft -8
ElseIf Target.Value = "" Then
Selection.Offset(0, -1).Select
Test
End If
Else
Exit Sub
End If
Application.ScreenUpdating = True
End Sub


Sub Test()
Const cDeleteOnTouch As Boolean = True
Dim rng As Range, shp As Shape, rngSelect As Range, blnDelete As
Boolean

Set rngSelect = Selection
MsgBox (rngSelect.Address)
For Each shp In Sheet1.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell,
shp.BottomRightCell), rngSelect)
If cDeleteOnTouch Then
If Not rng Is Nothing Then blnDelete = True
Else
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell,
shp.BottomRightCell).Address Then blnDelete = True
End If
End If

If blnDelete Then
MsgBox "delete " & shp.Name
shp.Delete
End If
Next
End Sub

 

[Billy Liddel]

Contextures.com has sample files for this on
http://www.contextures.com/excelfiles.html#Charts

Peter

 

[jlclyde]

Contextures.com has sample files for this onhttp://www.contextures.com/excelfiles.html#Charts

Peter








- Show quoted text -

Billy,
I had to change it around to work for my application but this works
great. It has reduced the file size and any need for code.
Thanks,
Jay