View Full Version : Copy position of elements to other elements

08-14-2007, 11:34 PM
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
08-15-2007, 06:25 AM
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
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

John Wilson
08-15-2007, 06:26 AM
I should have added a bit of error checking would be a good thing. Make sure you have one shape selected when you run!!

08-15-2007, 08:53 AM
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
08-15-2007, 02:27 PM
Like this maybe
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
With ActiveWindow.Selection.ShapeRange
.Left = lngLeft
.Top = lngTop
End With
End If
End Sub

08-16-2007, 12:49 AM
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.

08-16-2007, 07:19 PM
nevermind, i entered it wrong... thanks guys

03-17-2009, 06:08 PM
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.

03-17-2009, 06:12 PM
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:banghead:

John Wilson
03-18-2009, 02:07 AM
I think I probably made a mistake in the original left, top, width etc should be singles not longs.