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

Karatau · 30.08.2019

nagris сказал(а):
а если задать контур на нужном расстоянии от контура и проверить его пересечение и в пересечении поставить круг

есть метод определения пересечения в кореле?

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

tohaa · 30.08.2019

Karatau сказал(а):
А мне кажется, что задача решаема и довольно простым макросом. Сначала делаем контур у объекта нужной ширины и ищем точки пересечения с другими объектами по очереди. Точки пересечения обозначаем как хотим.

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

Да. Здорово. Не поможете с кодом? Я не нашел ничего похожего в сети.

Karatau · 31.08.2019

tohaa сказал(а):
Да. Здорово. Не поможете с кодом? Я не нашел ничего похожего в сети.

Помогу, конечно. Мой скайп wlad61740.

tohaa · 02.09.2019

Нашел макрос, который ставит точки в месте пересечения векторов между выделенными объектами.

Код:

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 · 03.09.2019

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

Т.е. вам надо типа такого?
В вашем случае придется сперва все элементы раскомбайнить. Иначе, получится вот так с текстом.
UPD: или текст по буквам разбить перед тем как задавать контур.

tohaa · 03.09.2019

lipatkin сказал(а):
Т.е. вам надо типа такого?
В вашем случае придется сперва все элементы раскомбайнить. Иначе, получится вот так с текстом.
UPD: или текст по буквам разбить перед тем как задавать контур.
Посмотреть вложение 121495

Я считаю, что проверку нужно делать следующим образом.

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

Alek32 · 06.09.2019

tohaa сказал(а):
Я считаю, что проверку нужно делать следующим образом.

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

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

Код:

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 · 06.09.2019

Alek32 сказал(а):

На первом скрине то что было, на втором после работы макроса. Но искал не места пересечения, а места наложения
Посмотреть вложение 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 & " перекрытий найдено"

Alek32 · 06.09.2019

tohaa сказал(а):
И подскажите как посчитать и вывести сообщение о том сколько пересечений найдено?

перед Set s3 = s1.Intersect(s2, True, True) добавить n=n+1 и в конце MsgBox n & "перекрытий найдено "

tohaa · 06.09.2019

Alek32 сказал(а):
перед Set s3 = s1.Intersect(s2, True, True) добавить n=n+1 и в конце MsgBox n & "перекрытий найдено "

Если выделено больше двух объектов - кол-во перекрытий не считается.

tohaa · 06.09.2019

tohaa сказал(а):
Если выделено больше двух объектов - кол-во перекрытий не считается.

извините. всё работает.

tohaa · 06.09.2019

Код:

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 ?

Поиск

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

Karatau

Участник

tohaa

Участник

Karatau

Участник

tohaa

Участник

eugeny

tohaa

Участник

Alek32

Участник

tohaa

Участник

Alek32

Участник

tohaa

Участник

tohaa

Участник

tohaa

Участник