ReplaceExactMatchIncludingGroups

Sub ReplaceExactMatchIncludingGroups()
    Dim doc As Document
    Set doc = ActiveDocument
    
    If doc.Selection.shapes.Count < 2 Then
        MsgBox "Please select target shapes/groups first, then Shift + Click the master new shape/group 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
    Dim replaceCount As Long
    
    Set selSet = doc.SelectionRange
    selCount = selSet.Count
    
    ' Master new shape or group (selected last)
    Set sourceShape = selSet(selCount)
    replaceCount = 0
    
    ' Get signature of the source shape/group
    Dim sourceNodes As Long, sourceArea As Double
    GetGroupOrShapeSignature sourceShape, sourceNodes, sourceArea
    
    doc.BeginCommandGroup "Replace Exact Match Including Groups"
    Optimization = True
    
    For i = 1 To selCount - 1
        Set targetShape = selSet(i)
        
        ' 1. STORE EXACT ORIGINAL POSITION & ROTATION BEFORE ANYTHING
        Dim origCX As Double, origCY As Double
        Dim origRot As Double
        
        origCX = targetShape.centerX
        origCY = targetShape.centerY
        origRot = targetShape.RotationAngle
        
        ' 2. Get signature of target shape/group
        Dim targetNodes As Long, targetArea As Double
        GetGroupOrShapeSignature targetShape, targetNodes, targetArea
        
        ' 3. Strict Match Check (Compare Node Count & Total Area)
        If targetNodes = sourceNodes And targetNodes > 0 Then
            ' Check Area match with 1% tolerance
            If Abs(sourceArea - targetArea) <= (sourceArea * 0.01) Or sourceArea = 0 Then
                
                ' Duplicate master source (Shape or Group)
                Set newShape = sourceShape.Duplicate
                
                ' Apply original exact rotation
                newShape.RotationAngle = origRot
                
                ' Position to original exact center point
                newShape.SetPositionEx cdrCenter, origCX, origCY
                
                ' Delete replaced target shape/group
                targetShape.Delete
                replaceCount = replaceCount + 1
            End If
        End If
    Next i
    
    Optimization = False
    ActiveWindow.Refresh
    doc.EndCommandGroup
    
    MsgBox "Done! Successfully replaced " & replaceCount & " exact matching object(s)/group(s).", vbInformation, "BITEPOINT DATA"
End Sub

' Helper: Calculate signature (Total Nodes & Area) for both Single Shapes and Grouped Objects
Private Sub GetGroupOrShapeSignature(sh As Shape, ByRef totalNodes As Long, ByRef totalArea As Double)
    totalNodes = 0
    totalArea = 0
    
    ' If the shape is a GROUP, loop through all child shapes inside
    If sh.Type = cdrGroupShape Then
        Dim subShape As Shape
        For Each subShape In sh.shapes
            Dim subNodes As Long, subArea As Double
            GetGroupOrShapeSignature subShape, subNodes, subArea
            totalNodes = totalNodes + subNodes
            totalArea = totalArea + subArea
        Next subShape
    Else
        ' If it is a normal Single Shape
        Dim c As Curve
        Set c = sh.DisplayCurve
        If Not c Is Nothing Then
            totalNodes = c.Nodes.Count
            On Error Resume Next
            totalArea = Round(c.area, 2)
            On Error GoTo 0
        End If
    End If
End Sub