Copy Formatting of Autoshape

[magnel]

Hi John,

Sometime back you helped me copy the yellow diamond adjustment of autoshapes with the below code.
Can you help me with a similar code where I can copy the (1) formatting, and (2) Height/width of autoshapes and paste to another.

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]

This should do it:

Dim sngW As Single
Dim sngH As Single
Dim lngRot As Long

Sub PickUpFormat()
Dim oshp As Shape
On Error GoTo err:
Set oshp = ActiveWindow.Selection.ShapeRange(1)
oshp.PickUp
sngW = oshp.Width
sngH = oshp.Height
lngRot = oshp.Rotation
Exit Sub
err:
MsgBox "Select Shape"
End Sub

Sub Apply_Format()
Dim oshp As Shape
On Error GoTo err:
For Each oshp In ActiveWindow.Selection.ShapeRange
oshp.Apply
oshp.LockAspectRatio = False
oshp.Width = sngW
oshp.Height = sngH
oshp.Rotation = lngRot
Next oshp
Exit Sub
err:
MsgBox "ERROR"
End Sub

[magnel]

Thanks John this is working perfectly as required.

[RayKay]

Hi John

With the above code, where an object you click will transfer its size and colour / fonts to any shape you click, could you adapt it so it takes on the same shape as well?

So if I had a Yellow Diamond 3cm x 10cm, Arial 10, say, then any shape I click after will be the same?

Thank you

[John Wilson]

Here's a starting point for you to work on:


Dim sngW As Single
Dim sngH As Single
Dim lngRot As Long
Dim lngType As Long


Sub PickUpFormat()
Dim oshp As Shape
On Error GoTo err:
Set oshp = ActiveWindow.Selection.ShapeRange(1)
oshp.PickUp
sngW = oshp.Width
sngH = oshp.Height
lngRot = oshp.Rotation
lngType = oshp.AutoShapeType
Exit Sub
err:
MsgBox "Select Shape"
End Sub


Sub Apply_Format()

Dim oshp As Shape
On Error GoTo err:
For Each oshp In ActiveWindow.Selection.ShapeRange
oshp.AutoShapeType = lngType
oshp.Apply
oshp.LockAspectRatio = False
oshp.Width = sngW
oshp.Height = sngH
oshp.Rotation = lngRot
Next oshp
Exit Sub
err:
MsgBox "ERROR"
End Sub

[RayKay]

Hi John

Thanks for the code, I've attempted editing it, but I get the ERROR message.

Sorry : pray2:

[John Wilson]

Show your edited code and the error message.

[RayKay]

Thanks John, here's my code:

(PS: I get my Module 3 error message pop-up)


Module 2:

Dim sngW As Single
Dim sngH As Single
Dim lngRot As Long
Dim lngType As Long
_______________________________


Sub CopyShape2()
Dim oshp As Shape
On Error GoTo err:
Set oshp = ActiveWindow.Selection.ShapeRange(1)
oshp.PickUp
sngW = oshp.Width
sngH = oshp.Height
lngRot = oshp.Rotation
lngType = oshp.AutoShapeType
Exit Sub
err:
MsgBox "Please Select a Shape"
End Sub


Module 3:

Dim sngW As Single
Dim sngH As Single
Dim lngRot As Long
Dim lngType As Long
_______________________________


Sub ChangeShape3()


Dim oshp As Shape
On Error GoTo err:
For Each oshp In ActiveWindow.Selection.ShapeRange
oshp.AutoShapeType = lngType
oshp.Apply
oshp.LockAspectRatio = False
oshp.Width = sngW
oshp.Height = sngH
oshp.Rotation = lngRot
Next oshp
Exit Sub
err:
MsgBox "Select a Shape first, or try again starting with the Copy Shape tool"
End Sub

[John Wilson]

It looks like you have put the sub routines into different modules and declared the variables twice.

Doing this would set the values back to zero in module 3 and almost certainly cause an error.

Solutions

1. easy - put all the code into one module
2. Declare the variables only once but as Public (not Dim)

If you are unclear about this option 1 is the way to go

[RayKay]

Thanks John. It works great as two modules, it doesn't work for me as one module :( To be honest, I don't know how to merge them into one module. Code is below.

And finally, can I make it so if a person clicks one shape, they can carry on clicking shapes until they press Escape? Thank you :thumb

Code:

Public sngW As Single
Public sngH As Single
Public lngRot As Long
Public lngType As Long




Sub CopyShape2()
Dim oShp As Shape
On Error GoTo err:
Set oShp = ActiveWindow.Selection.ShapeRange(1)
oShp.PickUp
sngW = oShp.Width
sngH = oShp.Height
lngRot = oShp.Rotation
lngType = oShp.AutoShapeType
Exit Sub
err:
MsgBox "Please Select a Shape"
End Sub


Sub ChangeShape3()


Dim oShp As Shape
On Error GoTo err:
For Each oShp In ActiveWindow.Selection.ShapeRange
oShp.AutoShapeType = lngType
oShp.Apply
oShp.LockAspectRatio = False
oShp.Width = sngW
oShp.Height = sngH
oShp.Rotation = lngRot
Next oShp
Exit Sub
err:
MsgBox "Select a Shape first, or try again starting with the Copy Shape tool"
End Sub