Location or Position of any object

[magnel]

Hi John,

Using the similar fashion below, please help me with a code that can pickup location or position of any object on the ppt slide and apply that to another object on the same slide or any other slide.

Dim adj() As Single 
Sub PickUp_Ang_Adj() 
    Dim oshp As Shape 
    Dim i As Integer 
On Error Goto err: 
    Set oshp = ActiveWindow.Selection.ShapeRange(1) 
    Redim adj(1 To oshp.Adjustments.Count) 
    For i = 1 To oshp.Adjustments.Count 
        adj(i) = oshp.Adjustments(i) 
    Next i 
    Exit Sub 
err: 
    MsgBox "Select Shape" 
End Sub 
 
Sub Apply_Ang_Adj() 
    Dim oshp As Shape 
    Dim i As Integer 
On Error Goto err: 
    For Each oshp In ActiveWindow.Selection.ShapeRange 
        Redim Preserve adj(1 To oshp.Adjustments.Count) 
        For i = 1 To oshp.Adjustments.Count 
            oshp.Adjustments(i) = adj(i) 
        Next i 
    Next oshp 
    Exit Sub 
err: 
    MsgBox "ERROR" 
End Sub

- Thanks

[John Wilson]

OK time to start coding yourself!

Start by adding two more variables at the top of the code (based on the format code you already have)

Dim sngW As Single
Dim sngH As Single
Dim lngRot As Long
Dim sngL as Single
Dim sngT as Single

Use the two new variable to store and apply the oshp.Left and oshp.Top in the same way as Width and Height.

You can do it!

[magnel]

wow, thanks John, got the required output.

[John Wilson]

Maybe post the code to help others.

[magnel]

Here is the code I used to get the result.

Dim sngL As Single
Dim sngT As Single


Sub Get_Loc()
Dim oshp As Shape
On Error GoTo err:
Set oshp = ActiveWindow.Selection.ShapeRange(1)
oshp.PickUp
sngL = oshp.Left
sngT = oshp.Top
Exit Sub
err:
MsgBox "Select Shape"
End Sub


Sub Set_Loc()
Dim oshp As Shape
On Error GoTo err:
For Each oshp In ActiveWindow.Selection.ShapeRange
oshp.Apply
oshp.LockAspectRatio = False
oshp.Left = sngL
oshp.Top = sngT
Next oshp
Exit Sub
err:
MsgBox "ERROR"
End Sub

[John Wilson]

That's good

You don't NEED to lock aspect ratio as you are not resizing but it won't do any damage! Pick Up and Apply will pick up and apply other things like fill etc They can be deleted if you don't need this.