[CDR 2024] Макрос замкнуть кривую

  • Автор темы Автор темы Verion
  • Дата начала Дата начала
Если кому интересно вот сейчас рабочая часть кода(правда не судите строго, писал с помощью нейронки плюс там дебагер, в порядок пока не приводил)
P.S. Вообще начинаются думать, что проще полностью переписать - Тупо поверх объектов нарисовать нужный, а начальные удалить(ну то бишь как запись макроса работает)
Sub ProcessObjects()
' Объявляем переменные
Dim leftShape As shape
Dim rightShape As shape
Dim leftNode As node
Dim rightNode As node
Dim sr As New ShapeRange

' Получаем активный документ и выделенные объекты
Dim doc As Document
Set doc = ActiveDocument

If doc Is Nothing Then
MsgBox "Документ не найден!", vbExclamation
Exit Sub
End If

' Проверяем, что выделено ровно два объекта
If ActiveSelection.Shapes.Count <> 2 Then
MsgBox "Выделите ровно два объекта!", vbExclamation
Exit Sub
End If

' Определяем левый и правый объекты по координате X
If ActiveSelection.Shapes(1).PositionX < ActiveSelection.Shapes(2).PositionX Then
Set leftShape = ActiveSelection.Shapes(1)
Set rightShape = ActiveSelection.Shapes(2)
Else
Set leftShape = ActiveSelection.Shapes(2)
Set rightShape = ActiveSelection.Shapes(1)
End If

' Находим нужные узлы
Set leftNode = FindRightTopNode(leftShape)
Set rightNode = FindLeftTopNode(rightShape)

If leftNode Is Nothing Or rightNode Is Nothing Then
MsgBox "Не удалось найти нужные узлы!", vbExclamation
Exit Sub
End If

' Разъединяем узлы (BreakApart)
leftNode.BreakApart
rightNode.BreakApart

' Разделяем концевые узлы на верхние и нижние
Dim topBottomPairs As Collection
Set topBottomPairs = AssignTopAndBottomNodes(leftShape, rightShape)

' Выводим информацию о верхних и нижних узлах
Debug.Print "Верхние и нижние узлы:"
Dim i As Long
For i = 1 To topBottomPairs.Count Step 2
Dim topNode As node
Dim bottomNode As node
Dim topNeighbor As node
Dim bottomNeighbor As node

Set topNode = topBottomPairs(i)
Set bottomNode = topBottomPairs(i + 1)

' Находим соседние узлы для верхнего и нижнего узлов
Set topNeighbor = GetNeighborNode(leftShape, topNode)
Set bottomNeighbor = GetNeighborNode(leftShape, bottomNode)

Debug.Print "Пара " & (i \ 2 + 1) & ":"
Debug.Print " Верхний узел: Индекс = " & topNode.Index & ", X = " & topNode.PositionX & ", Y = " & topNode.PositionY
Debug.Print " Соседний узел: Индекс = " & topNeighbor.Index & ", X = " & topNeighbor.PositionX & ", Y = " & topNeighbor.PositionY
Debug.Print " Нижний узел: Индекс = " & bottomNode.Index & ", X = " & bottomNode.PositionX & ", Y = " & bottomNode.PositionY
Debug.Print " Соседний узел: Индекс = " & bottomNeighbor.Index & ", X = " & bottomNeighbor.PositionX & ", Y = " & bottomNeighbor.PositionY
Next i

' Объединяем объекты
Set sr = ActiveSelectionRange
sr.Combine


MsgBox "Обработка завершена!", vbInformation
End Sub

' Функция для разделения концевых узлов на верхние и нижние
Function AssignTopAndBottomNodes(leftShape As shape, rightShape As shape) As Collection
Dim topBottomPairs As New Collection
Dim node1 As node, node2 As node
Dim neighbor1 As node, neighbor2 As node

' Разделяем концевые узлы левого объекта
Set node1 = leftShape.Curve.nodes(1) ' Первый узел
Set node2 = leftShape.Curve.nodes(leftShape.Curve.nodes.Count) ' Последний узел
Set neighbor1 = GetNeighborNode(leftShape, node1)
Set neighbor2 = GetNeighborNode(leftShape, node2)

If Not neighbor1 Is Nothing And Not neighbor2 Is Nothing Then
If neighbor1.PositionY < neighbor2.PositionY Then
topBottomPairs.Add node1 ' Верхний узел
topBottomPairs.Add node2 ' Нижний узел
Else
topBottomPairs.Add node2 ' Верхний узел
topBottomPairs.Add node1 ' Нижний узел
End If
End If

' Разделяем концевые узлы правого объекта
Set node1 = rightShape.Curve.nodes(1) ' Первый узел
Set node2 = rightShape.Curve.nodes(rightShape.Curve.nodes.Count) ' Последний узел
Set neighbor1 = GetNeighborNode(rightShape, node1)
Set neighbor2 = GetNeighborNode(rightShape, node2)

If Not neighbor1 Is Nothing And Not neighbor2 Is Nothing Then
If neighbor1.PositionY < neighbor2.PositionY Then
topBottomPairs.Add node1 ' Верхний узел
topBottomPairs.Add node2 ' Нижний узел
Else
topBottomPairs.Add node2 ' Верхний узел
topBottomPairs.Add node1 ' Нижний узел
End If
End If

Set AssignTopAndBottomNodes = topBottomPairs
End Function

' Функция для поиска самого правого верхнего узла
Function FindRightTopNode(shape As shape) As node
Dim node As node
Dim resultNode As node
Dim maxX As Double, minY As Double

If shape.Type <> cdrCurveShape Then Exit Function

maxX = -1E+308
minY = 1E+308

For Each node In shape.Curve.nodes
With node
If .PositionY < minY Or (.PositionY = minY And .PositionX > maxX) Then
maxX = .PositionX
minY = .PositionY
Set resultNode = node
End If
End With
Next node

Set FindRightTopNode = resultNode
End Function

' Функция для поиска самого левого верхнего узла
Function FindLeftTopNode(shape As shape) As node
Dim node As node
Dim resultNode As node
Dim minX As Double, minY As Double

If shape.Type <> cdrCurveShape Then Exit Function

minX = 1E+308
minY = 1E+308

For Each node In shape.Curve.nodes
With node
If .PositionY < minY Or (.PositionY = minY And .PositionX < minX) Then
minX = .PositionX
minY = .PositionY
Set resultNode = node
End If
End With
Next node

Set FindLeftTopNode = resultNode
End Function

' Функция для поиска соседнего узла
Function GetNeighborNode(shape As shape, node As node) As node
Dim segment As segment
Dim neighborNode As node

' Перебираем все сегменты кривой
For Each segment In shape.Curve.Segments
If segment.StartNode.Index = node.Index Then
' Найден сегмент, начинающийся с текущего узла
Set neighborNode = segment.EndNode
Exit For
ElseIf segment.EndNode.Index = node.Index Then
' Найден сегмент, заканчивающийся текущим узлом
Set neighborNode = segment.StartNode
Exit For
End If
Next segment

Set GetNeighborNode = neighborNode
End Function
 
Последнее редактирование:
Я все таки не разумею, чем вам JoinTouchingSubpath не подходит и каким образом вы собираетесь обьединять SubPaths без него, если ConnectWith не работает?
 
_MBK_ сказал(а):
Я все таки не разумею, чем вам JoinTouchingSubpath не подходит и каким образом вы собираетесь обьединять SubPaths без него, если ConnectWith не работает?
Нажмите, чтобы раскрыть...
Если я использую этот метод, то у меня объединяются соприкасающиеся узлы(то есть из этого объекта(картинка 1) я получаю этот(картинка 2)
 

Вложения

  • Screenshot_1.jpg
    Screenshot_1.jpg
    13.1 КБ · Просм.: 25
  • Screenshot_2.jpg
    Screenshot_2.jpg
    13.4 КБ · Просм.: 24
Последнее редактирование:
Verion сказал(а):
Если я использую этот метод, то у меня объединяются соприкасающиеся узлы(то есть из этого объекта(картинка 1) я получаю этот(картинка 2)
Нажмите, чтобы раскрыть...
Ну так раздвиньте ненужные ноды, сдвиньте нужные, слепите, затем снова ненужные верните в прежнее положение. Или у вас есть какой то менее заднепроходный способ?
 
  • Спасибо
Реакции: Verion
dastin сказал(а):
как это? две кривых с точками в одинковых координатах и не сварится?
Нажмите, чтобы раскрыть...
Ну даже если сварятся, у меня же две пары точек в одинаковых координатах, они сварятся как им вздумается, а мне важен порядок) Чтоб движение кривой было таким(см. картинку)
 

Вложения

  • Screenshot_3.jpg
    Screenshot_3.jpg
    30.1 КБ · Просм.: 21
_MBK_ сказал(а):
Ну так раздвиньте ненужные ноды, сдвиньте нужные, слепите, затем снова ненужные верните в прежнее положение. Или у вас есть какой то менее заднепроходный способ?
Нажмите, чтобы раскрыть...
Ну да, логику понимаю, попробую так)
 
Verion сказал(а):
две пары точек в одинаковых координатах, они сварятся
Нажмите, чтобы раскрыть...
в две точки ... координаты одни и те же - ведь для построения перемычек берутся координаты крайних точек
 
Итак победил таки эту задачу, хоть и через костыли, но сделал)
Благодарю всех за советы и идеи)
Вот что получилось в конечном итоге:
Sub ProcessObjects()
' Объявляем переменные
Dim leftShape As Shape
Dim rightShape As Shape
Dim leftNode As Node
Dim rightNode As Node

' Получаем активный документ и выделенные объекты
Dim doc As Document
Set doc = ActiveDocument

If doc Is Nothing Then
MsgBox "Документ не найден!", vbExclamation
Exit Sub
End If

' Проверяем, что выделено ровно два объекта
If ActiveSelection.Shapes.Count <> 2 Then
MsgBox "Выделите ровно два объекта!", vbExclamation
Exit Sub
End If

' Определяем левый и правый объекты по координате X
If ActiveSelection.Shapes(1).PositionX < ActiveSelection.Shapes(2).PositionX Then
Set leftShape = ActiveSelection.Shapes(1)
Set rightShape = ActiveSelection.Shapes(2)
Else
Set leftShape = ActiveSelection.Shapes(2)
Set rightShape = ActiveSelection.Shapes(1)
End If

' Находим нужные узлы
Set leftNode = FindRightTopNode(leftShape)
Set rightNode = FindLeftTopNode(rightShape)

If leftNode Is Nothing Or rightNode Is Nothing Then
MsgBox "Не удалось найти нужные узлы!", vbExclamation
Exit Sub
End If

' Разъединяем узлы (BreakApart)
leftNode.BreakApart
rightNode.BreakApart

' Разделяем концевые узлы на верхние и нижние
Dim topBottomPairs As Collection
Set topBottomPairs = AssignTopAndBottomNodes(leftShape, rightShape)

' *** Смещение верхней пары узлов на 4 мм вверх ***
Dim topNode1 As Node, topNode2 As Node
Dim bottomNode1 As Node, bottomNode2 As Node

' Исправленные строки для определения узлов
Set topNode1 = topBottomPairs(2) ' Верхний узел первого объекта
Set topNode2 = topBottomPairs(4) ' Верхний узел второго объекта
Set bottomNode1 = topBottomPairs(1) ' Нижний узел первого объекта
Set bottomNode2 = topBottomPairs(3) ' Нижний узел второго объекта

' Смещаем верхние узлы на 4 мм вверх
topNode1.SetPosition topNode1.PositionX, topNode1.PositionY + 4 * 0.03937
topNode2.SetPosition topNode2.PositionX, topNode2.PositionY + 4 * 0.03937

' *** Рисуем сегменты между узлами ***
Dim segment1 As Shape, segment2 As Shape

' Создаём сегмент между верхними узлами
Set segment1 = ActiveLayer.CreateLineSegment(topNode1.PositionX, topNode1.PositionY, topNode2.PositionX, topNode2.PositionY)

' Создаём сегмент между нижними узлами
Set segment2 = ActiveLayer.CreateLineSegment(bottomNode1.PositionX, bottomNode1.PositionY, bottomNode2.PositionX, bottomNode2.PositionY)

' *** Выделяем основной объект и нарисованные сегменты ***
ActiveDocument.ClearSelection ' Очищаем текущее выделение
leftShape.AddToSelection ' Добавляем левый объект
rightShape.AddToSelection ' Добавляем правый объект
segment1.AddToSelection ' Добавляем первый сегмент
segment2.AddToSelection ' Добавляем второй сегмент

' *** Сохраняем координаты верхних узлов перед объединением ***
Dim savedTopNode1X As Double, savedTopNode1Y As Double
Dim savedTopNode2X As Double, savedTopNode2Y As Double
savedTopNode1X = topNode1.PositionX
savedTopNode1Y = topNode1.PositionY
savedTopNode2X = topNode2.PositionX
savedTopNode2Y = topNode2.PositionY

' *** Объединяем выделенные объекты с помощью Combine ***
Dim sr As New ShapeRange
Set sr = ActiveSelectionRange
Dim combinedShape As Shape
Set combinedShape = sr.Combine ' Сохраняем ссылку на объединённый объект

' *** Добавляем объединение подпутей ***
On Error Resume Next
' Объединяем подпути для каждого объекта отдельно
combinedShape.Curve.JoinTouchingSubpaths

If Err.Number <> 0 Then
MsgBox "Ошибка при объединении подпутей: " & Err.Description, vbExclamation
Err.Clear
End If

' *** Возвращаем верхнюю пару узлов на 4 мм вниз ***
Dim node As Node
For Each node In combinedShape.Curve.Nodes
' Находим верхние узлы по их координатам
If Abs(node.PositionX - savedTopNode1X) < 0.000001 And Abs(node.PositionY - savedTopNode1Y) < 0.000001 Then
node.SetPosition node.PositionX, node.PositionY - 4 * 0.03937
ElseIf Abs(node.PositionX - savedTopNode2X) < 0.000001 And Abs(node.PositionY - savedTopNode2Y) < 0.000001 Then
node.SetPosition node.PositionX, node.PositionY - 4 * 0.03937
End If
Next node

MsgBox "Обработка завершена!", vbInformation
End Sub

' Функция для разделения концевых узлов на верхние и нижние
Function AssignTopAndBottomNodes(leftShape As Shape, rightShape As Shape) As Collection
Dim topBottomPairs As New Collection
Dim node1 As Node, node2 As Node
Dim neighbor1 As Node, neighbor2 As Node

' Разделяем концевые узлы левого объекта
Set node1 = leftShape.Curve.Nodes(1) ' Первый узел
Set node2 = leftShape.Curve.Nodes(leftShape.Curve.Nodes.Count) ' Последний узел
Set neighbor1 = GetNeighborNode(leftShape, node1)
Set neighbor2 = GetNeighborNode(leftShape, node2)

If Not neighbor1 Is Nothing And Not neighbor2 Is Nothing Then
If neighbor1.PositionY < neighbor2.PositionY Then
topBottomPairs.Add node1 ' Верхний узел
topBottomPairs.Add node2 ' Нижний узел
Else
topBottomPairs.Add node2 ' Верхний узел
topBottomPairs.Add node1 ' Нижний узел
End If
End If

' Разделяем концевые узлы правого объекта
Set node1 = rightShape.Curve.Nodes(1) ' Первый узел
Set node2 = rightShape.Curve.Nodes(rightShape.Curve.Nodes.Count) ' Последний узел
Set neighbor1 = GetNeighborNode(rightShape, node1)
Set neighbor2 = GetNeighborNode(rightShape, node2)

If Not neighbor1 Is Nothing And Not neighbor2 Is Nothing Then
If neighbor1.PositionY < neighbor2.PositionY Then
topBottomPairs.Add node1 ' Верхний узел
topBottomPairs.Add node2 ' Нижний узел
Else
topBottomPairs.Add node2 ' Верхний узел
topBottomPairs.Add node1 ' Нижний узел
End If
End If

Set AssignTopAndBottomNodes = topBottomPairs
End Function

' Функция для поиска самого правого верхнего узла
Function FindRightTopNode(shape As Shape) As Node
Dim node As Node
Dim resultNode As Node
Dim maxX As Double, minY As Double

If shape.Type <> cdrCurveShape Then Exit Function

maxX = -1E+308
minY = 1E+308

For Each node In shape.Curve.Nodes
With node
If .PositionY < minY Or (.PositionY = minY And .PositionX > maxX) Then
maxX = .PositionX
minY = .PositionY
Set resultNode = node
End If
End With
Next node

Set FindRightTopNode = resultNode
End Function

' Функция для поиска самого левого верхнего узла
Function FindLeftTopNode(shape As Shape) As Node
Dim node As Node
Dim resultNode As Node
Dim minX As Double, minY As Double

If shape.Type <> cdrCurveShape Then Exit Function

minX = 1E+308
minY = 1E+308

For Each node In shape.Curve.Nodes
With node
If .PositionY < minY Or (.PositionY = minY And .PositionX < minX) Then
minX = .PositionX
minY = .PositionY
Set resultNode = node
End If
End With
Next node

Set FindLeftTopNode = resultNode
End Function

' Функция для поиска соседнего узла
Function GetNeighborNode(shape As Shape, node As Node) As Node
Dim segment As Segment
Dim neighborNode As Node

' Перебираем все сегменты кривой
For Each segment In shape.Curve.Segments
If segment.StartNode.Index = node.Index Then
' Найден сегмент, начинающийся с текущего узла
Set neighborNode = segment.EndNode
Exit For
ElseIf segment.EndNode.Index = node.Index Then
' Найден сегмент, заканчивающийся текущим узлом
Set neighborNode = segment.StartNode
Exit For
End If
Next segment

Set GetNeighborNode = neighborNode
End Function
 
Verion сказал(а):
Вот что получилось
Нажмите, чтобы раскрыть...
Будем пробовать. Для CNC весьма полезная штука - быстро задавать точки входа, как мне кажется, если добавить в код разрыв выделенного узла и далее по тексту.
 
Последнее редактирование:
mnemonix сказал(а):
Будем пробовать. Для CNC весьма полезная штука - быстро задавать точки входа, как мне кажется, если добавить в код разрыв выделенного узла и далее по тексту.
Нажмите, чтобы раскрыть...
Обычно в CAM и задаешь, или просто говоришь - сделай все точки хода внизу-вверху-слева-справа..., или явно указываешь и оставляешь там, где указано. В Vectric Aspire, по крайней мере, так. Хотя, не скрою, иногда было бы удобно задать их уже в Кореле. Особенно для шрифтов
1744289237193.png
 
Последнее редактирование:
Да, я про Сorel, зачастую самому проще указать, особенно для лазерной резки, чтобы он не сходил с ума и экономил время. Тем более если это массовое производство.
 
Последнее редактирование:
хотел предложить вам добавить в изначальный код
Код: 
Dim c As Shape
  Set c = sr.Combine
  c.Curve.SubPaths(1).StartNode.ConnectWith c.Curve.SubPaths(2).EndNode
  c.Curve.Closed = True
но, раз справились сами, то и нормально
 
  • Спасибо
Реакции: mnemonix и Verion
Verion сказал(а):
Не подскажешь что за функцию использовал?
Нажмите, чтобы раскрыть...
Я писал его на заказ еще для Корел X3, там не было этих новых функций из VBA7. Помню, что делал коллекцию узлов и в цикле соединял ближайшие из них. Обычный NodeRange не подходил для этих целей потому, что после первого же соединения менялся весь порядок узлов.
 
Для ответа нужно войти/зарегистрироваться
Верх Низ