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

  • Спасибо
Реакции: DukereD
Берём за начальный объект самый нижний (ну или верхний, или нижний левый, сами код поправите), находим ближайший к нему, отправляем назад, обработанный шейп исключаем из перебора. Коммивояжеры не нужны. Достаточно примитива.
За координату объекта берём координату его первой точки (для большей оптимальности стоило бы перебирать все точки каждого объекта с поиском ближайшей, а не первую, но это притормозит+усложнит код, оставляю эту задачу Вам)
Объекты могут быть разомкнутыми, например, линии реза для облегчения выборки плёнки, или в графическом рисунке, который мы не режем, а выжигаем лазером или рисуем рейсфедером/фломастером и т.п., тогда надо дописать код, чтобы расстояние искалось от конечной точки текущего шейпа.
В принципе, подобные функции уже существуют в софте для резчиков. В рамках Корела это 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
lev сказал(а):
В принципе, подобные функции уже существуют в софте для резчиков. В рамках Корела это PlotCalc, e-Cut
Нажмите, чтобы раскрыть...
Возможно это

eCut для CorelDRAW - Functions > Оптимизатор пути

www.e-cut.ru www.e-cut.ru
lev сказал(а):
Коммивояжеры не нужны. Достаточно примитива.
Нажмите, чтобы раскрыть...
Тут стоимость времени станка vs стоимость работы программиста. Жадность побеждает.
 
Какая ошибка? У меня на Х7 работает.
PosLine - забыл удалить вызов функции, рисовал тестовую линию хода режущей головки для проверки результата работы
 
lev сказал(а):
Какая ошибка? У меня на Х7 работает.
PosLine - забыл удалить вызов функции, рисовал тестовую линию хода режущей головки для проверки результата работы
Нажмите, чтобы раскрыть...
1644602409214.png

n там равно нулю в этом цикле.
1644602458751.png
 
Вот запустил код под 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
 
Последнее редактирование:
Попробовал еще раз и снова ошибка.
в итоге помогло таки не то что я делал а
ActiveDocument.Unit = cdrMillimeter
цифры похоже что-то не понравились ему в микрометрах.
 
этишкин код!))) этак вы здесь полноценную прогу счас забабацаете))))
 
ух... работает! перемещений пустых в три раза меньше! СПАСИБО! Вы мне очень помогли... Как жить без гениев?))) Башковитых?
 

Вложения

  • neobrabot.png
    neobrabot.png
    7.3 КБ · Просм.: 226
  • obrabot.png
    obrabot.png
    7.3 КБ · Просм.: 198
Дмитрий2022 сказал(а):
перемещений пустых в три раза меньше!
Нажмите, чтобы раскрыть...
Ну это самая грубая оптимизация. На самом деле, следующий уровень будет искать ближайший шейп не по позиции, а именно по ближайшему узлу от текущего узла. И т.д. совершенству предела нет и, повторяю, все придумано за нас.
 
lev сказал(а):
Сортируем по верхнему левому углу
Код: 
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
Для ответа нужно войти/зарегистрироваться
Верх Низ