Sub JoinMultipleCurvesWithBridges()
ActiveDocument.Unit = cdrMillimeter
Application.Optimization = True
ActiveDocument.BeginCommandGroup "Smart Join Curves"
On Error GoTo ErrorHandler
Dim sr As ShapeRange
Dim s As Shape
Dim crv As Curve
Dim sp As SubPath
Dim nodes() As Node
Dim used() As Boolean
Dim nCount As Long
Dim i As Long, j As Long
Dim tol As Double
Dim dx As Double, dy As Double, d As Double
Dim bestD As Double, bestJ As Long
Dim bridges As New ShapeRange ' Коллекция для новых линий-перемычек
Dim bridge As Shape
' === НАСТРОЙКИ ===
tol = 5 ' Допуск поиска пары в мм (увеличьте, если разрывы большие)
' =================
Set sr = ActiveSelectionRange
If sr.Count < 1 Then
MsgBox "Выделите несколько кривых.", vbExclamation
GoTo ExitLabel
End If
' 1. Объединяем выделенное в один объект, чтобы работать с SubPaths
' Если выделен уже один объект, Combine вернет его же
Set s = sr.Combine
' Преобразуем в кривые, если вдруг там были прямоугольники/эллипсы
If s.Type <> cdrCurveShape Then s.ConvertToCurves
Set crv = s.Curve
nCount = 0
' 2. Собираем концы всех открытых подпутей
For Each sp In crv.SubPaths
If Not sp.Closed Then
nCount = nCount + 2
ReDim Preserve nodes(1 To nCount)
ReDim Preserve used(1 To nCount)
Set nodes(nCount - 1) = sp.StartNode
Set nodes(nCount) = sp.EndNode
used(nCount - 1) = False
used(nCount) = False
End If
Next sp
If nCount < 2 Then
' Если всё уже замкнуто - отлично
GoTo ExitLabel
End If
' 3. Ищем пары и строим "мосты"
For i = 1 To nCount
If Not used(i) Then
bestD = 1E+30
bestJ = 0
For j = 1 To nCount
If j <> i And Not used(j) Then
dx = nodes(j).PositionX - nodes(i).PositionX
dy = nodes(j).PositionY - nodes(i).PositionY
d = Sqr(dx * dx + dy * dy)
If d < bestD Then
bestD = d
bestJ = j
End If
End If
Next j
' Если нашли пару в пределах допуска
If bestJ > 0 And bestD <= tol Then
used(i) = True
used(bestJ) = True
' Создаем линию соединения
Set bridge = ActiveLayer.CreateLineSegment( _
nodes(i).PositionX, nodes(i).PositionY, _
nodes(bestJ).PositionX, nodes(bestJ).PositionY)
bridges.Add bridge
End If
End If
Next i
' 4. Финальная сборка: объединяем исходную кривую с новыми мостами
If bridges.Count > 0 Then
bridges.Add s ' Добавляем исходную кривую в группу к мостам
Set s = bridges.Combine ' Сливаем всё вместе
' 5. Теперь у нас единый объект, но узлы в местах стыков могут быть "раздвоены"
' (конец линии + начало моста). Используем JoinTouchingSubpaths, чтобы "сварить" их.
' Допуск ставим маленький (0.01), т.к. мы построили мосты точно в координаты.
s.Curve.JoinTouchingSubpaths True, 0.1
End If
ExitLabel:
ActiveDocument.EndCommandGroup
Application.Optimization = False
Application.Refresh
Exit Sub
ErrorHandler:
MsgBox "Ошибка: " & Err.Description
Resume ExitLabel
End Sub
