[CDR 2017-2021] Измерение расстояния между объектами на листе.

Karatau

Участник
Сообщения
60
Реакции
22
а если задать контур на нужном расстоянии от контура и проверить его пересечение и в пересечении поставить круг

есть метод определения пересечения в кореле?
Функция GetIntersections возвращает координаты точек пересечения двух SubPath -ов.
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
А мне кажется, что задача решаема и довольно простым макросом. Сначала делаем контур у объекта нужной ширины и ищем точки пересечения с другими объектами по очереди. Точки пересечения обозначаем как хотим.

Посмотреть вложение 121398
Такой контур получается из толстого арабиса. Все объекты сравниваются в очереди, сверху вниз
Да. Здорово. Не поможете с кодом? Я не нашел ничего похожего в сети.
 

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Нашел макрос, который ставит точки в месте пересечения векторов между выделенными объектами.


Код:
Sub NodesToInterssects()
Dim s As Shape
Dim nr As New NodeRange
Dim cps As CrossPoints
Dim cp As CrossPoint
ActiveDocument.BeginCommandGroup "NodesToIntersects"
Set s = ActiveSelectionRange.Combine
Set cps = s.Curve.SubPaths(1).GetIntersections(s.Curve.SubPaths(2), cdrAbsoluteSegmentOffset)
For Each cp In cps

nr.Add s.Curve.SubPaths(1).AddNodeAt(cp.Offset, cdrAbsoluteSegmentOffset)

nr.Add s.Curve.SubPaths(2).AddNodeAt(cp.Offset2, cdrAbsoluteSegmentOffset)
Next cp
s.BreakApart
ActiveTool = cdrToolPick
ActiveSelectionRange.RemoveFromSelection
ActiveDocument.EndCommandGroup
End Sub

Теперь нужно как-то создавать контур выделенных объектов

Код:
.CreateContour(, ConvertUnits(0.2, cdrMillimeter, ActiveDocument.Unit), , , , sOriginal.Fill.UniformColor.GetCopy)

видимо как-то эти контура именовать и искать пересечения непосредственно между контурами. В случае если такое пересечение найдено - рисовать красный маркер в этой точке.

Код:
ActiveLayer.CreateEllipse2 cp.PositionX, cp.PositionY, 0.05

как это всё собрать вместе я не знаю. Не хватает квалификации.

Но, кажется, алгоритм будет работать.
Вопрос в том, как перебрать все созданные контура и проверить их пересечение.
 

eugeny

15 лет на форуме
Сообщения
855
Реакции
210
Но, кажется, алгоритм будет работать.
Вопрос в том, как перебрать все созданные контура и проверить их пересечение.
Т.е. вам надо типа такого?
В вашем случае придется сперва все элементы раскомбайнить. Иначе, получится вот так с текстом.
UPD: или текст по буквам разбить перед тем как задавать контур.
Screenshot_14.jpg
 
Последнее редактирование:

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Т.е. вам надо типа такого?
В вашем случае придется сперва все элементы раскомбайнить. Иначе, получится вот так с текстом.
UPD: или текст по буквам разбить перед тем как задавать контур.
Посмотреть вложение 121495
Я считаю, что проверку нужно делать следующим образом.

1. выделить мышью объекты для проверки
2. сделать копию выделенных объектов, сдвинуть их в сторону от рабочего поля.
3. раскомбайнить все объекты копии
4. создать контура вокрут раскомбинированных объектов.
5. обнаружить пересечения контуров.
6. выделить места пересечения маркерами.
 

Alek32

Участник
Сообщения
25
Реакции
18
Я считаю, что проверку нужно делать следующим образом.

1. выделить мышью объекты для проверки
2. сделать копию выделенных объектов, сдвинуть их в сторону от рабочего поля.
3. раскомбайнить все объекты копии
4. создать контура вокрут раскомбинированных объектов.
5. обнаружить пересечения контуров.
6. выделить места пересечения маркерами.

На первом скрине то что было, на втором после работы макроса. Но искал не места пересечения, а места наложения
121584
121585


Код:
Sub Macro1()
    Dim OrigSelection As ShapeRange
    Dim OrigSelection1 As ShapeRange
    Dim OrigSelection2 As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Set OrigSelection2 = New ShapeRange
    Dim eff1 As Effect
    For i = 1 To OrigSelection.Count
        Set eff1 = OrigSelection(i).CreateContour(1, 0.19685, 1, 0, , , , 0, 0, 2, 4, 15#)
        Set OrigSelection1 = OrigSelection(i).Effects.ContourEffect.Separate
        OrigSelection2.Add OrigSelection1(1)
    Next i
    Dim s1 As Shape
    Dim s2 As Shape
    Dim s3 As Shape
    For sh = 1 To OrigSelection2.Count
        Set s1 = OrigSelection2(sh)
        For i = sh + 1 To OrigSelection2.Count
                Set s2 = OrigSelection2(i)
                If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
                    Set s3 = s1.Intersect(s2, True, True)
                    s3.Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
                End If
        Next i
    Next sh
    For Each sh In OrigSelection2
        OrigSelection2.Delete
    Next sh
End Sub
 
  • Спасибо
Реакции: tohaa и nagris

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
На первом скрине то что было, на втором после работы макроса. Но искал не места пересечения, а места наложения
Посмотреть вложение 121584Посмотреть вложение 121585

Код:
Sub Macro1()
    Dim OrigSelection As ShapeRange
    Dim OrigSelection1 As ShapeRange
    Dim OrigSelection2 As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Set OrigSelection2 = New ShapeRange
    Dim eff1 As Effect
    For i = 1 To OrigSelection.Count
        Set eff1 = OrigSelection(i).CreateContour(1, 0.19685, 1, 0, , , , 0, 0, 2, 4, 15#)
        Set OrigSelection1 = OrigSelection(i).Effects.ContourEffect.Separate
        OrigSelection2.Add OrigSelection1(1)
    Next i
    Dim s1 As Shape
    Dim s2 As Shape
    Dim s3 As Shape
    For sh = 1 To OrigSelection2.Count
        Set s1 = OrigSelection2(sh)
        For i = sh + 1 To OrigSelection2.Count
                Set s2 = OrigSelection2(i)
                If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
                    Set s3 = s1.Intersect(s2, True, True)
                    s3.Fill.ApplyUniformFill CreateCMYKColor(0, 0, 0, 100)
                End If
        Next i
    Next sh
    For Each sh In OrigSelection2
        OrigSelection2.Delete
    Next sh
End Sub

Отлично! А как сделать чтобы макрос мог работать с одним комбинированным объектом? Сейчас он запускается и работает только в случае, если выделено два или больше объектов. Но часто бывает что объект один, но состоит из множества контуров, расстояние между которыми тоже нужно померить и пометить, в случае, если они меньше заданного значения.

И подскажите как посчитать и вывести сообщение о том сколько пересечений найдено?
что-то типа:
MsgBox s3.Count & " перекрытий найдено"
 
Последнее редактирование:

tohaa

Участник
Топикстартер
Сообщения
229
Реакции
8
Код:
Sub cross_lines()
ActiveDocument.Unit = cdrMillimeter
 Dim sr As ShapeRange, shl As Shape
    Set sr = ActiveSelectionRange
        For Each shl In sr
        If Not shl.Outline.Type = cdrNoOutline Then
        shl.Outline.ConvertToObject
        End If
    Next
    sr.BreakApart
  'perevodim v obekty
 Dim OrigSelection As ShapeRange
    Dim OrigSelection1 As ShapeRange
    Dim OrigSelection2 As ShapeRange

    Set OrigSelection = ActiveSelectionRange
    Set OrigSelection2 = New ShapeRange
    Dim eff1 As Effect
       For i = 1 To OrigSelection.Count
        Set eff1 = OrigSelection(i).CreateContour(1, 0.1, 1, 0, , , , 0, 0, 2, 4, 15#)
        Set OrigSelection1 = OrigSelection(i).Effects.ContourEffect.Separate
        OrigSelection2.Add OrigSelection1(1)
    Next i
    Dim s1 As Shape
    Dim s2 As Shape
    Dim s3 As Shape
    For sh = 1 To OrigSelection2.Count
        Set s1 = OrigSelection2(sh)
        For i = sh + 1 To OrigSelection2.Count
                Set s2 = OrigSelection2(i)
                If s1.DisplayCurve.IntersectsWith(s2.DisplayCurve) Then
                    n = n + 1
                    Set s3 = s1.Intersect(s2, True, True)
                    s3.Fill.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
                End If
        Next i
    Next sh
    For Each sh In OrigSelection2
        OrigSelection2.Delete
    Next sh
    MsgBox "0" & n & " " & перекрытий найдено"
End Sub

1. перевожу все объекты с обводкой в объекты
2. раскомбинирую объекты и выделение с объектов сбрасывается.
Как сделать, чтобы раскомбинированные объекты стали ActiveSelectionRange ?