BatchReplaceShapesKeepScale_VBA_CorelDRAW

 ទីមួយសូមជ្រើសរើស រូបភាពដែលចង់ផ្លាស់ប្ដូរជាមុន បន្ទាប់មកសូមជ្រើសរើសរូបភាពទាំងអស់ដែលត្រូវផ្លាស់ប្ដូរ។ Shift + Click Selection

Option Explicit
Sub BatchReplaceShapesKeepScale()
    Dim doc As Document
    Set doc = ActiveDocument
    
    ' Check if at least 2 objects are selected
    If doc.Selection.Shapes.Count < 2 Then
        MsgBox "Please select all old shapes first, then Shift + Click the new shape last!", vbExclamation, "BITEPOINT DATA"
        Exit Sub
    End If
    
    Dim sourceShape As Shape
    Dim targetShape As Shape
    Dim newShape As Shape
    Dim i As Long
    Dim selCount As Long
    Dim selSet As ShapeRange
    
    Set selSet = doc.SelectionRange
    selCount = selSet.Count
    
    ' The last selected item is the master Source Shape
    Set sourceShape = selSet(selCount)
    
    doc.BeginCommandGroup "Exact Replace Keep Scale"
    
    Optimization = True
    
    For i = 1 To selCount - 1
        Set targetShape = selSet(i)
        
        Dim origCX As Double, origCY As Double
        Dim origRot As Double
        
        ' 1. Get exact Center position and Rotation Angle of old shape
        origCX = targetShape.CenterX
        origCY = targetShape.CenterY
        origRot = targetShape.RotationAngle
        
        ' 2. Duplicate the new source shape
        Set newShape = sourceShape.Duplicate
        
        ' 3. Apply exact rotation of the old shape
        newShape.RotationAngle = origRot
        
        ' 4. Align Center to Center (100% exact without affecting scale)
        newShape.SetPositionEx cdrCenter, origCX, origCY
        
        ' 5. Delete the old shape
        targetShape.Delete
    Next i
    
    Optimization = False
    ActiveWindow.Refresh
    
    doc.EndCommandGroup
End Sub