quote:

---

UndoScopeID1 = Application.BeginUndoScope("temp")
ActiveWindow.DeselectAll
A0F2.Cells("width") = 10 * A0F2.Cells("width")

ActiveWindow.Select A0F2, visSelect
ActiveWindow.Select okr, visSelect
ActiveWindow.Selection.Trim
Set temp = ActiveWindow.Selection(1)
x = temp.Cells("endX")
y = temp.Cells("endY")
Application.EndUndoScope UndoScopeID1, True 'false все отменит

Set A2 = точка(x, y, "A_2") 'ставим точку в координатах

---

quote:

---

The original shapes are deleted and no shapes are selected when the operation is complete.

---

quote:

---

The original shapes are deleted and there aren't any shapes selected when the operation is complete.

---

UndoScopeID1 = Application.BeginUndoScope("temp")
    ActiveWindow.DeselectAll
    A0F2.Cells("width") = 10 * A0F2.Cells("width") 'extend 10 times to get 100% intersection
    
    ActiveWindow.Select A0F2, visSelect
    ActiveWindow.Select okr, visSelect
    shapeCount0 = ActivePage.Shapes.Count
    ActiveWindow.Selection.Trim
    shapeCount = ActivePage.Shapes.Count
    Debug.Print shapeCount - shapeCount0
    
    ActiveWindow.DeselectAll
    
        For i = shapeCount0 - 1 To shapeCount
            Set vsoShape1 = ActivePage.Shapes(i)
            Debug.Print vsoShape1.name
            ActiveWindow.Select vsoShape1, visSelect
        Next

Function пересечение(ByVal fig1 As Object, ByVal fig2 As Object, Optional ByVal удлинять As Boolean = True) As Variant
x = 0
y = 0
       UndoScopeID1 = Application.BeginUndoScope("temp")
    ActiveWindow.DeselectAll
    
    If удлинять Then
        ang = fig1.Cells("angle")
        fig1.Cells("endX") = fig1.Cells("endX") + 100 * Cos(ang)
        fig1.Cells("endY") = fig1.Cells("endY") + 100 * Sin(ang)
    End If
    
    ActiveWindow.Select fig1, visSelect
    ActiveWindow.Select fig2, visSelect
    
    shapeCount0 = ActivePage.Shapes.Count
    ActiveWindow.Selection.Trim
    shapeCount = ActivePage.Shapes.Count
    'Debug.Print "*******************"
    'Debug.Print shapeCount - shapeCount0 + 2

    ActiveWindow.DeselectAll
        k = 0
        Dim shsi()  As Variant
        Dim sh0, sh1 As Visio.Shape
        For i = shapeCount0 - 1 To shapeCount 'две стартовые удаляются - остальные новые
            Set sh1 = ActivePage.Shapes(i)
              geom_c = sh1.GeometryCount 'число секций
              geom1_r = sh1.RowCount(visSectionFirstComponent) 'рядов в секции
              h = Round(sh1.Cells("height").Result("mm"), 1) 'рядов в секции
                  
              
            ' Debug.Print h
            If h = 0 Then
                  ReDim Preserve shsi(k + 1)
                  shsi(k) = i
           '       Debug.Print shsi(k)
                  k = k + 1
                  ActiveWindow.Select sh1, visSelect
            End If
        Next


         Set sh0 = ActivePage.Shapes(shsi(0))
            Debug.Print k
         For i = 1 To k - 1
         '   Debug.Print shsi(k)
            Set sh1 = ActivePage.Shapes(shsi(i))
            
                If (sh0.Cells("beginX") = sh1.Cells("beginX") And _
                sh0.Cells("beginY") = sh1.Cells("beginY")) Then
                    x = sh0.Cells("beginX")
                    y = sh0.Cells("beginY")
                    Exit For
                End If
                
                If (sh0.Cells("beginX") = sh1.Cells("endX") And _
                sh0.Cells("beginY") = sh1.Cells("endY")) Then
                    x = sh0.Cells("beginX")
                    y = sh0.Cells("beginY")
                    Exit For
                End If
                
                If (sh0.Cells("endX") = sh1.Cells("beginX") And _
                sh0.Cells("endY") = sh1.Cells("beginY")) Then
                    x = sh0.Cells("beginX")
                    y = sh0.Cells("beginY")
                    Exit For
                End If
                
                If (sh0.Cells("endX") = sh1.Cells("endX") And _
                sh0.Cells("endY") = sh1.Cells("endY")) Then
                    x = sh0.Cells("beginX")
                    y = sh0.Cells("beginY")
                    Exit For
                End If
                 'ActiveWindow.Select sh1, visSelect
        Next
 
        
    Application.EndUndoScope UndoScopeID1, False

  'Debug.Print x & "-" & y
пересечение = Array(x, y)
End Function