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.

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" <(E-Mail Removed)> wrote in message
news:7B8D6CEB-07F6-4301-A4D2-(E-Mail Removed)...
> 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.

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" wrote:

> 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" <(E-Mail Removed)> wrote in message
> news:7B8D6CEB-07F6-4301-A4D2-(E-Mail Removed)...
> > 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.
>
>
> .
>

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

"Gary B" <(E-Mail Removed)> wrote in message
news25DF480-6CEA-43D3-91C9-(E-Mail Removed)...
> 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" wrote:
>
>> 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" <(E-Mail Removed)> wrote in message
>> news:7B8D6CEB-07F6-4301-A4D2-(E-Mail Removed)...
>> > 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.
>>
>>
>> .
>>