Hi John, I've tried to adapt your following code to be one Module, and not two:
Public sngW As Single
Public sngH As Single
Public lngRot As Long
Public lngType As Long
Sub CopyShape1()
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 ChangeShape2()
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
But my code fails when I try to make it work with one button... so, say you have a triangle with text and you want to click a few squares to turn into that matching triangle, I'm hoping this tool would do it. Much like the Format Painter, but it takes the Shape and its colors too. Thank you.
Here is my poor effort:
Public sngW As Single
Public sngH As Single
Public lngRot As Long
Public lngType As Long
Sub ApplyMyShape1()
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"
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
End Sub
Thank you.