Copy position of elements to other elements

[chenshenglun]

Hi. I'm looking for something that is along the lines for the format painter but I want it to copy positions (horizontal, vertical) from one element to another. Is this possible?

[John Wilson]

Like this maybe. You might want to add the macros to a right click menu for speed See http://www.pptalchemy.co.uk/rightmacro.html
[vba]Public lngLeft As Long
Public lngTop As Long
Sub pick()
lngLeft = ActiveWindow.Selection.ShapeRange.Left
lngTop = ActiveWindow.Selection.ShapeRange.Top
End Sub
Sub place()
ActiveWindow.Selection.ShapeRange.Left = lngLeft
ActiveWindow.Selection.ShapeRange.Top = lngTop
End Sub[/vba]

[John Wilson]

I should have added a bit of error checking would be a good thing. Make sure you have one shape selected when you run!!

[TrippyTom]

Hi Jon,

I use something like this as well and was using the upper left corner too, but I was wondering if we could expand it to let the user pick the location to memorize. (the corners of the bounding box, or the center).

Would that be too involved?

[John Wilson]

Like this maybe
[vba]Public lngTop as long
Public lngLeft as long
Public lngcentreLeft As Long
Public lngcentreTop As Long
Sub pick()
With ActiveWindow.Selection.ShapeRange(1)
lngLeft = .Left
lngTop = .Top
lngcentreLeft = .Left + (.Width / 2)
lngcentreTop = .Top + (.Height / 2)
End With
End Sub
Sub place()
Dim response
response = MsgBox("Do you want to align centres?", vbYesNo)
If response = vbYes Then
With ActiveWindow.Selection.ShapeRange
.Top = lngcentreTop - .Height / 2
.Left = lngcentreLeft - .Width / 2
End With
Else
With ActiveWindow.Selection.ShapeRange
.Left = lngLeft
.Top = lngTop
End With
End If
End Sub[/vba]

[chenshenglun]

Thanks for the help guys, although it seems for me that the "pick" part isn't working. whenever I use the place it seems to just send it to the top left corner.

[chenshenglun]

nevermind, i entered it wrong... thanks guys

[marathi.bana]

Hi,
I found one error, it keep 1 pt difference. Run this macro to more than one slide on same type of autoshape and check in slideshow. You will find autoshape jumping.

[marathi.bana]

Public lngWidth As Long
Public lngHeight As Long
Sub pickSize()
lngWidth = ActiveWindow.Selection.ShapeRange.width
lngHeight = ActiveWindow.Selection.ShapeRange.height
End Sub
Sub placeSize()
ActiveWindow.Selection.ShapeRange.width = lngWidth

ActiveWindow.Selection.ShapeRange.height = lngHeight
End Sub

I used above code to make autoshape of same size but it creat difference of one inch in width.

Can somebody help me to fix this problem

[John Wilson]

I think I probably made a mistake in the original left, top, width etc should be singles not longs.