See if this works Select first the original shape and then the new shape with ctrl and run
Sub SizeAndSwap()
Dim oTarget As Shape
Dim oSource As Shape
Dim sngL As Single
Dim sngT As Single
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count = 2 Then
On Error GoTo err
Set oSource = ActiveWindow.Selection.ShapeRange(1)
Set oTarget = ActiveWindow.Selection.ShapeRange(2)
oTarget.Width = oSource.Width
oTarget.Height = oSource.Height
sngL = oTarget.Left
sngT = oTarget.Top
oTarget.Left = oSource.Left
oTarget.Top = oSource.Top
oSource.Left = sngL
oSource.Top = sngT
If MsgBox("Delete original?", vbInformation + vbYesNo) = vbYes Then oSource.Delete
Else
MsgBox "You need to select TWO shapes", vbCritical
End If
Exit Sub
err:
MsgBox "No shapes are selected.", vbCritical
End Sub
Ideally it would need a button permanently on the ribbon to run it and some more error checking. We could do this for you but it would have to go through the books and there would be a small charge.
johnATpptalchemy.co.uk
Last edited by JohnWilson; 09-18-2013 at 02:15 AM.
|