[CDR 2017-2021] Автоматизация порядка объектов в диспетчере

mnemonix

ॐ मणि पद्मे हूँ
Сообщения
576
Реакции
174

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
  • Спасибо
Реакции: DukereD

lev

Модератор
20 лет на форуме
Сообщения
2 142
Реакции
2 066
Берём за начальный объект самый нижний (ну или верхний, или нижний левый, сами код поправите), находим ближайший к нему, отправляем назад, обработанный шейп исключаем из перебора. Коммивояжеры не нужны. Достаточно примитива.
За координату объекта берём координату его первой точки (для большей оптимальности стоило бы перебирать все точки каждого объекта с поиском ближайшей, а не первую, но это притормозит+усложнит код, оставляю эту задачу Вам)
Объекты могут быть разомкнутыми, например, линии реза для облегчения выборки плёнки, или в графическом рисунке, который мы не режем, а выжигаем лазером или рисуем рейсфедером/фломастером и т.п., тогда надо дописать код, чтобы расстояние искалось от конечной точки текущего шейпа.
В принципе, подобные функции уже существуют в софте для резчиков. В рамках Корела это PlotCalc, e-Cut (в каком-то из них точно видел функцию минимизации пути перемещения головки)
Код:
Sub srt_nearest()
  ActiveDocument.BeginCommandGroup "Sort by Nearest"
  'найти нижний
  Dim sr As ShapeRange
  n = 1
  t = 100000000
  Set sr = ActiveLayer.Shapes.All 'ActiveSelection.Shapes.All
  For Each s In sr
    If s.DisplayCurve.Nodes.First.PositionY < t Then
      t = s.DisplayCurve.Nodes.First.PositionY
      lowest = n
    End If
    n = n + 1
  Next s
  n = lowest

  While sr.Count > 1
    'удалить из перебора текущий
    Set s = sr(n)
    sr.Remove n
    'перебрать шейпы найти ближайший
    n = GetNearestShape(s, sr)
    'change order
    sr(n).OrderBackOf s
  Wend
  ActiveDocument.EndCommandGroup
End Sub
Function GetNearestShape(s, sr) As Long  'Shape
  t = 100000000
  sx = s.DisplayCurve.Nodes.First.PositionX
  sy = s.DisplayCurve.Nodes.First.PositionY
  n = 1
  min_n = 0
  For Each s1 In sr
    s1x = s1.DisplayCurve.Nodes.First.PositionX
    s1y = s1.DisplayCurve.Nodes.First.PositionY
    dist = ((sx - s1x) * (sx - s1x) + (sy - s1y) * (sy - s1y)) 'можно без корня
    If dist < t Then
      t = dist
      min_n = n
    End If
    n = n + 1
  Next s1
  GetNearestShape = min_n  'sr(min_n)
End Function
 
Последнее редактирование:
  • Спасибо
Реакции: dastin, DukereD и mnemonix

splxgf

12 лет на форуме
Сообщения
7 740
Реакции
3 421
В принципе, подобные функции уже существуют в софте для резчиков. В рамках Корела это PlotCalc, e-Cut
Возможно это
Коммивояжеры не нужны. Достаточно примитива.
Тут стоимость времени станка vs стоимость работы программиста. Жадность побеждает.
 

DukereD

макрософил
Сообщения
459
Реакции
112

lev

Модератор
20 лет на форуме
Сообщения
2 142
Реакции
2 066
Какая ошибка? У меня на Х7 работает.
PosLine - забыл удалить вызов функции, рисовал тестовую линию хода режущей головки для проверки результата работы
 

DukereD

макрософил
Сообщения
459
Реакции
112
Какая ошибка? У меня на Х7 работает.
PosLine - забыл удалить вызов функции, рисовал тестовую линию хода режущей головки для проверки результата работы
1644602409214.png

n там равно нулю в этом цикле.
1644602458751.png
 

lev

Модератор
20 лет на форуме
Сообщения
2 142
Реакции
2 066

DukereD

макрософил
Сообщения
459
Реакции
112
Вот запустил код под 2021 корел.
1644603608229.png


Код:
Sub srt_nearest()
  ActiveDocument.BeginCommandGroup "Sort by Nearest"
  Dim sr As ShapeRange
  n = 1
  t = 100000000
  Set sr = ActiveSelectionRange
  For Each s In sr.Shapes
    If s.DisplayCurve.Nodes.First.PositionY < t Then
      t = s.DisplayCurve.Nodes.First.PositionY
      lowest = n
    End If
    n = n + 1
  Next s
  n = lowest

  While sr.Shapes.Count > 1 And n > 0
    Set s = sr(n)
    s.CreateSelection
    sr.Remove n
    n = GetNearestShape(s, sr.Shapes)
    sr(n).OrderBackOf s
  Wend
  ActiveDocument.EndCommandGroup
End Sub

Function GetNearestShape(s, sr) As Long  'Shape
  t = 100000000
  sx = s.DisplayCurve.Nodes.First.PositionX
  sy = s.DisplayCurve.Nodes.First.PositionY
  n = 1
  min_n = 0
  For Each s1 In sr
    s1x = s1.DisplayCurve.Nodes.First.PositionX
    s1y = s1.DisplayCurve.Nodes.First.PositionY
    dist = ((sx - s1x) * (sx - s1x) + (sy - s1y) * (sy - s1y))
    If dist < t Then
      t = dist
      min_n = n
    End If
    n = n + 1
  Next s1
  GetNearestShape = min_n  'sr(min_n)
End Function
 
Последнее редактирование:

DukereD

макрософил
Сообщения
459
Реакции
112
Попробовал еще раз и снова ошибка.
в итоге помогло таки не то что я делал а
ActiveDocument.Unit = cdrMillimeter
цифры похоже что-то не понравились ему в микрометрах.
 

Дмитрий2022

Участник
Топикстартер
Сообщения
23
Реакции
0
этишкин код!))) этак вы здесь полноценную прогу счас забабацаете))))
 

Дмитрий2022

Участник
Топикстартер
Сообщения
23
Реакции
0
ух... работает! перемещений пустых в три раза меньше! СПАСИБО! Вы мне очень помогли... Как жить без гениев?))) Башковитых?
 

Вложения

  • neobrabot.png
    neobrabot.png
    7.3 КБ · Просм.: 185
  • obrabot.png
    obrabot.png
    7.3 КБ · Просм.: 156

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 138
Реакции
10 835
перемещений пустых в три раза меньше!
Ну это самая грубая оптимизация. На самом деле, следующий уровень будет искать ближайший шейп не по позиции, а именно по ближайшему узлу от текущего узла. И т.д. совершенству предела нет и, повторяю, все придумано за нас.
 

DukereD

макрософил
Сообщения
459
Реакции
112
Сортируем по верхнему левому углу
Код:
Sub PosSortOrder()
  ActiveDocument.BeginCommandGroup "sort by pos"
  Set sr = ActiveLayer.Shapes.All
  sr.Sort "@shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
  For Each s In sr.Shapes
    s.OrderToBack
  Next s
  ActiveDocument.EndCommandGroup
End Sub
немного переделал алгоритм для сортировки если объекты стоят немного не ровно (по центрам)
степень погрешности зависит от самого маленького объекта

Код:
Sub sort_by_pos(Optional shft = 0) 'Lev https://forum.rudtp.ru/threads/avtomatizacija-porjadka-obektov-v-dispetchere.78746/post-1292379
    Dim os As ShapeRange
    Set os = ActiveSelectionRange
    If os.Shapes.Count > 1 Then
        ActiveDocument.BeginCommandGroup "sort by pos"
        ActiveDocument.Unit = cdrTenthMicron
        If shft = 1 Then srt = "<" Else srt = ">"
        os.Sort "@shape1.height < @shape2.height"
        mn = os.FirstShape.SizeHeight
        mx = os.LastShape.SizeHeight
        os.Sort "(@shape1.centery.value()/" & mn & ").ToInt * 100 * " & mn & " - @shape1.centerx.value().ToInt" & srt & _
               " (@shape2.centery.value()/" & mn & ").ToInt * 100 * " & mn & " - @shape2.centerx.value().ToInt"
        For Each s In os.Shapes
          s.OrderToBack
        Next s
        ActiveDocument.EndCommandGroup
    End If
End Sub
 
  • Спасибо
Реакции: mnemonix