Hello.
I'm would to ask for your help in creating a macro that does the same as the "Edit | Copy Propeties from..." does but that copy the size.
Much like this: 1st : you have a shape selected, 2nd You run the macro, 3rd You click on the final shape.
This is the code I'm using in a VBA form with 2 buttons, btnSelectShape and btnApplyToShape.
Option ExplicitPublic sel As ShapePublic newsel As ShapePublic u As StringPublic prevu As cdrUnitPublic msgAnswer As StringPublic h, w, r As StringSub GetShapeProperties() Set sel = Application.ActiveDocument.ActiveShape prevu = Application.ActiveDocument.Unit Application.ActiveDocument.Unit = cdrMillimeter u = ActiveDocument.WorldScale If ActiveSelectionRange.Count = 0 Then MsgBox "No Shape is Selected", vbRetryCancel, "CorelDRAW" Else h = sel.SizeHeight w = sel.SizeWidth r = sel.RotationAngle End If' MsgBox ("H:" & h & " W:" & w & " R:" & r) sel.RemoveFromSelectionEnd SubSub SetShapeProperties() prevu = Application.ActiveDocument.Unit Application.ActiveDocument.Unit = cdrMillimeter u = ActiveDocument.WorldScale If ActiveSelectionRange.Count = 0 Then MsgBox "No Text Shape is Selected", vbRetryCancel, "CorelDRAW" Else Set newsel = Application.ActiveDocument.ActiveShape newsel.RotationAngle = r newsel.SizeHeight = h newsel.SizeWidth = w End If Dim response As String response = MsgBox("Do you want to Delete the first Shape?", vbYesNo, "CorelDRAW") If response = vbYes Then sel.AddToSelection ActiveSelection.AlignAndDistribute cdrAlignDistributeHAlignCenter, cdrAlignDistributeVAlignCenter, cdrAlignShapesToLastSelected, cdrDistributeToSelection newsel.RemoveFromSelection ActiveSelectionRange.Delete Else End If End SubPrivate Sub btnApplyToShape_Click() SetShapePropertiesEnd SubPrivate Sub btnSelectShape_Click() GetShapePropertiesEnd Sub
I'm doing this but using a form. Is the a way to remove the form and do it using just a mouse click in the final shape?
Thank you very much.
You can try code below - 1. select shapes you want to resize, 2. run macro, 3. click on "source" object
Sub Replace_size()Dim i#, design As Shape, ph1 As Shape, sw#, sh#, mx#, my#, z&Dim placeholder As Shape, x2 As Double, y2 As Double, sr As ShapeRangeActiveDocument.BeginCommandGroup "set_size" Set sr = ActiveSelectionRange If sr.Count = 0 Then MsgBox ("Nothing Selected!"): Exit Sub If ActiveDocument.GetUserClick(mx, my, z, -1, Snap:=False, CursorShape:=309) Then Exit Sub With ActivePage.SelectShapesAtPoint(mx, my, SelectUnfilled:=True) Set placeholder = .Shapes(.Shapes.Count) End With sr.CreateSelection For i = 1 To sr.Count Set design = ActiveSelection.Shapes.Item(i) design.GetPositionEx cdrCenter, x2, y2 design.SetSize placeholder.SizeWidth, placeholder.SizeHeight design.SetPositionEx cdrCenter, x2, y2 Next i ActiveDocument.EndCommandGroupEnd Sub