Adding shapes to worksheet

[Gary B]

Hi,
I have the following code

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing

End Sub

This works just fine. However, If I add more than one shape to a sheet,
then subsequently delete a shape using the code below, other shapes on the
same worksheet move a little.

Sub DeletePicture(TargetCells As Range)
Dim pict As Object
Dim t As Double
Dim l As Double

Application.ScreenUpdating = False
' determine positions
With TargetCells
t = .Top
l = .Left
End With

For Each pict In ActiveSheet.Shapes
On Error Resume Next
pict.Select
If Round(pict.Left, 2) = Round(l, 2) And Round(pict.Top, 2) =
Round(t, 2) Then
pict.Delete
End If
Next

Application.ScreenUpdating = True

End Sub

Any suggestions to improve the code, so that each shape is "locked in place"
when it is added ?

Thanks in advance.

 

[Peter T]

No need to Select your pictures. Here's a different approach -

Sub DeletePicture2(TargetCells As Range)
Dim pic As Picture

For Each pic In ActiveSheet.Pictures
If Not Intersect(TargetCells, pic.TopLeftCell) Is Nothing Then
pic.Delete
End If
Next

End Sub

If You want to delete all shapes whose topLeftCell is in the target change
'As Picture' to As Shape' and 'ActiveSheet.Pictures' to 'ActiveSheet.Shapes'

Regards,
Peter T

 

[Gary B]

Thanks for that.

Your code did not delete my shape, but I did remove my line that was
selecting the shape before deletion. That has worked a treat - simply don't
select the shape.

Your guidance was most helpful.

 

[Peter T]

I just tested the code as posted and it should delete any or all Pictures
whose topLeftCell is within the target range "TargetCells". Not sure why it
doesn't for you, no matter, glad you got it working for your needs.

Regards,
Peter T