G
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.
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.