G
Guest
Hello.
I have a macro which is used in a sheet used to draw diagrams. The user
clicks on the shape which is then copied, enlarged and pasted a few cells to
the right.
The problem I am having is that the macro is still assigned to the pasted
shape, so when a user clicks on this shape, to move or resize it, the macro
runs again. So they end up with shapes all over the place.
Can anyone tell me how to remove the macro from the pasted shape?
Here is the macro...
Sub Macro1()
ActiveSheet.Unprotect
Dim shp As Shape
Dim name As String
'Change Rectangle 22 to actual name of shape
name = ActiveSheet.Shapes(Application.Caller).name
On Error GoTo Badentry
'Selects the shape using the name of the active shape
Set shp = ActiveSheet.Shapes(name)
shp.Select
'Change Range to wherever keeping counter
Selection.Copy
'Change Range to wherever pasting shape
ActiveCell.Offset(0, 4).Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
ActiveSheet.Protect DrawingObjects:=False, Contents:=True,
Scenarios:=True
Exit Sub
Badentry:
msg = "An error has occurred."
msg = msg + vbNewLine + vbNewLine
msg = msg + "Click on the name of an item in the menu, and then on the
grey key."
msg = msg + vbNewLine + vbNewLine
msg = msg + "If you still get an error, e-mail P&D Technical Support Team"
Ans = MsgBox(msg, vbExclamation, "Menu Problem")
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub
I have a macro which is used in a sheet used to draw diagrams. The user
clicks on the shape which is then copied, enlarged and pasted a few cells to
the right.
The problem I am having is that the macro is still assigned to the pasted
shape, so when a user clicks on this shape, to move or resize it, the macro
runs again. So they end up with shapes all over the place.
Can anyone tell me how to remove the macro from the pasted shape?
Here is the macro...
Sub Macro1()
ActiveSheet.Unprotect
Dim shp As Shape
Dim name As String
'Change Rectangle 22 to actual name of shape
name = ActiveSheet.Shapes(Application.Caller).name
On Error GoTo Badentry
'Selects the shape using the name of the active shape
Set shp = ActiveSheet.Shapes(name)
shp.Select
'Change Range to wherever keeping counter
Selection.Copy
'Change Range to wherever pasting shape
ActiveCell.Offset(0, 4).Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
ActiveSheet.Protect DrawingObjects:=False, Contents:=True,
Scenarios:=True
Exit Sub
Badentry:
msg = "An error has occurred."
msg = msg + vbNewLine + vbNewLine
msg = msg + "Click on the name of an item in the menu, and then on the
grey key."
msg = msg + vbNewLine + vbNewLine
msg = msg + "If you still get an error, e-mail P&D Technical Support Team"
Ans = MsgBox(msg, vbExclamation, "Menu Problem")
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub