Fixing yellow diamond in autoshape

[magnel]

Hello,

I am using ppt 2010 and i wanted to copy the angle (yellow diamond setting) of one autoshape and paste it to another similar autoshape.

I found the below code, but somehow it does not work as I want it.

Sub ShowAdjustments()
Dim oSh As Shape
Dim lCount As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)

With oSh
For lCount = 1 To .Adjustments.Count
MsgBox "Adjustment " & CStr(lCount) _
& vbCrLf & CStr(.Adjustments(lCount))
Next
End With

End Sub


Sub SetAdjustments()

Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)

With oSh
.Adjustments(1) = 0.66
.Adjustments(2) = 0.66
' And so on for add'l adjustments
End With

End Sub

Please can someone help me with a code that copy the angle setting of the selected autoshape and the second code that paste the copied angle setting to the selected autoshape.

[John Wilson]

Select the shape to Copy settings and then ctrl click the shape to be changed

Run this (the shapes need the same number of adjuster points)

Sub Adjustments()
Dim oSh1 As Shape
Dim oSh2 As Shape
Dim lCount As Long
Set oSh1 = ActiveWindow.Selection.ShapeRange(1)
Set oSh2 = ActiveWindow.Selection.ShapeRange(2)
For lCount = 1 To oSh1.Adjustments.Count
oSh2.Adjustments(lCount) = oSh1.Adjustments(lCount)
Next
End Sub

[magnel]

Thanks John, this piece of code works very well when used on autoshapes on the same slide, you are a genius.

Is it possible to split this code, where one code copies the adjustment of the selected autoshape and second code does the paste of that adjustment on any selected autoshape on another slide?

[John Wilson]

Use PickUp to copy the adjustment and Apply to apply it!

Dim adj() As Single

Sub pickUpAdj()
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 "ERROR"
End Sub

Sub applyAdj()
Dim oshp As Shape
Dim i As Integer
On Error GoTo err:
Set oshp = ActiveWindow.Selection.ShapeRange(1)
ReDim Preserve adj(1 To oshp.Adjustments.Count)
For i = 1 To oshp.Adjustments.Count
oshp.Adjustments(i) = adj(i)
Next i
Exit Sub
err:
MsgBox "ERROR"
End Sub

[magnel]

This works exactly as I wanted the code to function. Thank you so much John :)

[magnel]

Hello John, In "Sub applyAdj()" is it possible to select more than one shape and apply the adjustment.

[John Wilson]

If they are on the same slide - yes.



Sub applyAdj()
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

[magnel]

Thank you so much John, really helpful in saving the time it takes while adjusting the yellow diamond. Awesome! :)

[magnel]

Hi John, can you help me with a code that copies an autoshape's formatting and pasting to the other as we did above, like copying the angle of one shape and applying it to the other selected ones. Thanks.

[John Wilson]

You need to explain what you mean by "Angle" (maybe rotation?) and it' susually best to start a new thread with a new problem.

[magnel]

Sure John, I will start a new thread, thanks