Copy Shape size to another shape with mouse click

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 Explicit
Public sel As Shape
Public newsel As Shape
Public u As String
Public prevu As cdrUnit
Public msgAnswer As String
Public h, w, r As String

Sub 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.RemoveFromSelection
End Sub

Sub 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 Sub
Private Sub btnApplyToShape_Click()
    SetShapeProperties
End Sub

Private Sub btnSelectShape_Click()
    GetShapeProperties
End 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.

Parents
  • 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 ShapeRange
    ActiveDocument.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.EndCommandGroup
    End Sub

Reply Children
No Data