Set vs = Application.ActiveWindow.Selection
Application.ActiveWindow.Page.Drop Application.ActiveDocument.Masters.ItemU("X"), 0, 0
Set Xsh = Application.ActiveWindow.Selection

params = Array("BeginX", "BeginY", "EndX", "EndY")
    For Each p In params
    Xsh(1).Cells(p) = vs(1).Cells(p)
    Next p
   
vs.Delete

Public Function ConnectedShapes(ByVal sh As Visio.Shape)
Dim Passive() As Visio.Shape
Dim Active() As Visio.Shape

    'Set sh = ActiveWindow.Selection.Item(1) 'выделенный шейп
    'Активные связи 2D-шейпа
    If sh.Connects.Count > 0 Then 'условие наличия активных связей
    For I = 1 To sh.Connects.Count 'цикл перебора всех активных связей
    ReDim Preserve Active(I)
    Set Active(I - 1) = sh.Connects().ToSheet 'активные связи (к чему приклеен)
   ' Debug.Print "active " & Active(I - 1).Name
    Next
    End If

    'Пассивные связи 2D-шейпа
    If sh.FromConnects.Count > 0 Then 'условие наличия пассивных связей
    For I = 1 To sh.FromConnects.Count 'цикл перебора всех пассивных связей
    ReDim Preserve Passive(I)
    Set Passive(I - 1) = sh.FromConnects(I).FromSheet 'пассивные связи (какие шейпы приклеены к выделенному)
  '  Debug.Print "passive " & Passive(I - 1).Name
    Next
    End If
    
    ConnectedShapes = Array(Active, Passive)
End Function

Public Function ConnectedCells(ByVal sh As Visio.Shape)

Dim strFrom(), strTo() As String
Dim vsoConnectTo(), vsoConnectFrom() As Visio.Shape

        Set vsoConnects = sh.Connects

        'For each connection, get the shape it connects to
        'and the part of the shape it connects to,
        'and print that information in the Immediate window.
        For intCounter = 0 To vsoConnects.Count - 1
            ReDim Preserve strTo(intCounter + 1), vsoConnectTo(intCounter + 1)
            
            Set vsoConnect = vsoConnects(intCounter + 1)
            Set vsoConnectTo(intCounter) = vsoConnect.ToSheet
            intToData = vsoConnect.ToPart

            If intToData = visConnectError Then
                strTo(intCounter) = "error"
            ElseIf intToData = visNone Then
                strTo(intCounter) = "none"
            ElseIf intToData = visGuideX Then
                strTo(intCounter) = "guideX"
            ElseIf intToData = visGuideY Then
                strTo(intCounter) = "guideY"
            ElseIf intToData = visWholeShape Then
                strTo(intCounter) = "dynamic glue"
            ElseIf intToData >= visConnectionPoint Then
                strTo(intCounter) = "connection point " & _
                    CStr(intToData - visConnectionPoint + 1)
            Else
                strTo(intCounter) = "???"
            End If

            'Print the name and part of the shape the
            'Connect object connects to.
           ' Debug.Print "To " & vsoConnectTo(intCounter).Name & " " & strTo(intCounter) & "."
    Next intCounter


        'For each connection, get the shape it originates from
        'and the part of the shape it originates from,
        'and print that information in the Immediate window.
        For intCounter = 0 To vsoConnects.Count - 1
            ReDim Preserve strFrom(intCounter + 1), vsoConnectFrom(intCounter + 1)
            Set vsoConnect = vsoConnects(intCounter + 1)
            Set vsoConnectFrom(intCounter) = vsoConnect.FromSheet
            intFromData = vsoConnect.FromPart
            
'Debug.Print "vsoFrom " & vsoConnectFrom(intCounter).Name

            'FromPart property values
            If intFromData = visConnectError Then
                strFrom(intCounter) = "error"
            ElseIf intFromData = visNone Then
                strFrom(intCounter) = "none"
            ElseIf intFromData = visLeftEdge Then
                strFrom(intCounter) = "left"
            ElseIf intFromData = visCenterEdge Then
                strFrom(intCounter) = "center"
            ElseIf intFromData = visRightEdge Then
                strFrom(intCounter) = "right"
            ElseIf intFromData = visBottomEdge Then
                strFrom(intCounter) = "bottom"
            ElseIf intFromData = visMiddleEdge Then
                strFrom(intCounter) = "middle"
            ElseIf intFromData = visTopEdge Then
                strFrom(intCounter) = "top"
            ElseIf intFromData = visBeginX Then
                strFrom(intCounter) = "beginX"
            ElseIf intFromData = visBeginY Then
                strFrom(intCounter) = "beginY"
            ElseIf intFromData = visBegin Then
                strFrom(intCounter) = "begin"
            ElseIf intFromData = visEndX Then
                strFrom(intCounter) = "endX"
            ElseIf intFromData = visEndY Then
                strFrom(intCounter) = "endY"
            ElseIf intFromData = visEnd Then
                strFrom(intCounter) = "end"
            ElseIf intFromData >= visControlPoint Then
                strFrom(intCounter) = "controlPt_" & _
                    str(intFromData - visControlPoint + 1)
            Else
                strFrom(intCounter) = "???"
            End If

          '  Debug.Print "From " & vsoConnectFrom(intCounter).Name & " " & strFrom(intCounter)

        Next intCounter

    ConnectedCells1 = Array(vsoConnectTo, strTo, vsoConnectFrom, strFrom)

        If False Then 'debug
        For j = 0 To UBound(ConnectedCells1) - 1
            ar = ConnectedCells1(j)
            text = ""
            For I = 0 To UBound(ar) - 1
            text = text & ar(I) & "  "
            Next I
            'Debug.Print j & " " & text
        Next j
        End If
    ConnectedCells = ConnectedCells1
End Function