Макрос для ХЗ для сборки визиток

  • Автор темы Автор темы Toh_A
  • Дата начала Дата начала
Статус
Закрыто для дальнейших ответов.
Ответ: Макрос для ХЗ для сборки визиток

Skvoznyak

Проблема в том, что задача раскроя материала не имеет строгого решения.
Только перебор.

Ага... Вспоминаем классику, задача комивояжора (немного оптимизируется, но с трудом). Задача раскраски карты (Вроде уже доказана)

Проблема вторая, что, например, в офсете влезают технологические проблемы оптимизации по цвету, по резу и подбору.

Фигня, если 1000 листов бумаги нашинковать, а вот когда милионные тиражи, это вполне ральные время и деньги.

Prinect Signa может делать оптимизацию, причём более-менее, только вот о цветах она имеет весьма слабое представление, оптимизирует скорее по резу, но вот этикетки одного вида в гуппы объединять, это уже с трудом.
 
Ответ: Макрос для ХЗ для сборки визиток

JAW сказал(а):
Prinect Signa может делать оптимизацию, причём более-менее, только вот о цветах она имеет весьма слабое представление, оптимизирует скорее по резу, но вот этикетки одного вида в гуппы объединять, это уже с трудом.
Нажмите, чтобы раскрыть...
Да, она оптимизирует только по размеру. Но можно выкрутиться: создать две одинаковых (по размеру) заготовки как 2 разных вида.
 
Ответ: Макрос для ХЗ для сборки визиток

Вот родил чего-то тут.. В простейшем случае, когда все куски одинакового размера, например визитки, вроде работает. Вобщем накидываем на лист визитки, расставляем их приблизительно, на глазок, выделяем и запускаем макрос. Если так подойдет, можно и метки еще добавить, это не проблема.

Код: 
Sub Fizitki()
Dim Sel As ShapeRange, S As Shape, St() As New ShapeRange, Tmp As New ShapeRange
Dim I As Integer, Changed As Boolean, U As Integer, Finded As Boolean
    
    If Documents.Count = 0 Then Exit Sub
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.ReferencePoint = cdrCenter
    Set Sel = ActiveSelectionRange
    If Sel.Count < 2 Then Exit Sub
    
    Do
    Changed = False
    For Each S In Sel
        For I = 2 To Sel.Count
            If S.PositionX <> Sel(I).PositionX Then
                If Abs(S.PositionX - Sel(I).PositionX) < 45 Then
                    Sel(I).PositionX = S.PositionX
                    Changed = True
                    Exit For
                End If
            End If
        Next
    Next
    Loop While Changed
    
    ReDim St(1)
    St(1).Add Sel(1)
    For I = 2 To Sel.Count
        Finded = False
        For U = 1 To UBound(St)
            If Sel(I).PositionX = St(U)(1).PositionX Then
                St(U).Add Sel(I)
                Finded = True
                Exit For
            End If
        Next
        If Not Finded Then
            ReDim Preserve St(UBound(St) + 1)
            St(UBound(St)).Add Sel(I)
        End If
    Next
    
    Do
        Changed = False
        For I = 1 To UBound(St) - 1
            If St(I)(1).PositionX > St(I + 1)(1).PositionX Then
                Set Tmp = St(I)
                Set St(I) = St(I + 1)
                Set St(I + 1) = Tmp
                Changed = True
                Exit For
            End If
        Next
    Loop While Changed
    
    For I = 1 To UBound(St)
        Do
        Changed = False
            For U = 1 To St(I).Count - 1
                If St(I)(U).PositionY > St(I)(U + 1).PositionY Then
                    Set S = St(I)(U)
                    St(I).Remove U
                    St(I).Add S
                    Changed = True
                    Exit For
                End If
            Next
        Loop While Changed
    Next
    
    For I = 1 To UBound(St)
        For U = 1 To St(I).Count - 1
            St(I)(U + 1).PositionY = St(I)(U).TopY + St(I)(U + 1).SizeHeight / 2
        Next
        
        If I <> 1 Then
            St(I).PositionX = St(I - 1).RightX + St(I).SizeWidth / 2
            St(I).PositionY = St(I - 1).PositionY
        End If
    Next
    
End Sub
 
Ответ: Макрос для ХЗ для сборки визиток

У _MBK_ вроде, насколько я понял, и не стояла задача оптимального раскроя. У него уже все и так расположено как надо, задача только подбить все встык.
 
Ответ: Макрос для ХЗ для сборки визиток

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

Именно так! Огромное спасибо, получилось именно то, что мне надо! Единственно что - под 11 корелом выдает ошибку 438 в строке

St(I).PositionX = St(I - 1).RightX + St(I).SizeWidth / 2

Не совсем пойму, что ей не нравится.
И, конечно же, хотелось бы метки ;-)
 
Ответ: Макрос для ХЗ для сборки визиток

По поводу подогнать объекты в стык есть макрос Shaping, расставить метки реза - макрос CropMarks. Ищем по поиску на этом форуме... Однотипные визитки на спуск собрать - это на обероне макрос Tiller кажись.. Влом искать.... Не надо изобретать велосипед....

А вообще есть идея сбора спуска со шкалками, метками там и прочей лабудой. Собственно для ся я такой написал, но думаю в каждой типухе свои устои и правила сбора спусков. Так что если есть желание можем обсудить как это количество нюансов обобщить для каждого в единый многофункциональный макрос... если стоит конечно овчинка выделки...
 
Ответ: Макрос для ХЗ для сборки визиток

По 11-й никогда не писал ничего, и у меня его нет, проверить не могу...
Но судя по ошибке (438 - Object doesn't support this property or method) скорей всего в нем нет свойств у Shape типа RightX, TopY... Ну это не проблема, легко и самим их вычислить, как сумма координаты центра плюс половина ширины или соотв. высоты.

По поводу меток, из головы вылетело, есть уже готовое решение -
http://forum.rudtp.ru/showthread.php?t=31244&highlight=Cropmarker
Сам им пользуюсь, единственное что плохо, если для навороченных объектов метки ставить, долго думает.
 
Ответ: Макрос для ХЗ для сборки визиток

Asmussen сказал(а):
По 11-й никогда не писал ничего, и у меня его нет, проверить не могу...
Но судя по ошибке (438 - Object doesn't support this property or method) скорей всего в нем нет свойств у Shape типа RightX, TopY... Ну это не проблема, легко и самим их вычислить, как сумма координаты центра плюс половина ширины или соотв. высоты.

По поводу меток, из головы вылетело, есть уже готовое решение -
http://forum.rudtp.ru/showthread.php?t=31244&highlight=Cropmarker
Сам им пользуюсь, единственное что плохо, если для навороченных объектов метки ставить, долго думает.
Нажмите, чтобы раскрыть...

Вот, наконец то по существу отвечать начали, а то все какие-то отвлеченные разговоры об оптимизации раскроя и т. д. Оказывается все уже давно придумано и лежит на форуме, а никто не подскажет. ;-)
Что за макрос Shaping и где его искать? По поводу ошибки - у Shape свойства есть, я уже код сам покрутил, ошибка возникает только тогда, когда пытаешься присваивать переприсваивать свойства из между элементами одного и того же массива. В 11 кореле какая-то заморочка бейсика, такое впечатление, что в пределах одного цикла он или только писать или только читать свойства элемента может что ли? :-(
 
Ответ: Макрос для ХЗ для сборки визиток

Ну действительно, если Shaping это делает, то к чему тогда заморочки.
Я просто не в курсе, не пользовался никогда им.
Найдете поиском по слову Shaping.
Правда не знаю какие Корелы он поддерживает, есть сомнения насчет 11-го, спросите автора. :)
 
Ответ: Макрос для ХЗ для сборки визиток

_MBK_ сказал(а):
Что за макрос Shaping и где его искать?
Нажмите, чтобы раскрыть...
Я же сказал по поиску на этом форуме - Shaping

Не по теме:
Вау - уже 608 скачиваний!... Да я звездю
 
Ответ: Макрос для ХЗ для сборки визиток

Asmussen сказал(а):
есть сомнения насчет 11-го, спросите автора. :)
Нажмите, чтобы раскрыть...
Да.. не поддерживает.. Такая у меня политика фирмы. Мол не фиг старьем пользоваться... Ну тама код не сложный.. Можно и самому написать при желании.
 
Ответ: Макрос для ХЗ для сборки визиток

Да, действительно, ни Shaping, ни CropMarks под 11 корел не идут. В принципе, CropMarks и не подходит, он только угловые метки расставляет а мне по периметру метки реза надо.
Я разобрался в чем проблема была изначально. Я слегка ступил, действительно в 11 кореле не поддерживаются свойства TopY и RightX. Совместимый под 11 корел код выглядит так:
Код: 
Sub Fizitki()
Dim Sel As ShapeRange, S As Shape, St() As New ShapeRange, Tmp As New ShapeRange
Dim I As Integer, Changed As Boolean, U As Integer, Finded As Boolean
    
    If Documents.Count = 0 Then Exit Sub
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.ReferencePoint = cdrCenter
    Set Sel = ActiveSelectionRange
    If Sel.Count < 2 Then Exit Sub
    
    Do
    Changed = False
    For Each S In Sel
        For I = 2 To Sel.Count
            If S.PositionX <> Sel(I).PositionX Then
                If Abs(S.PositionX - Sel(I).PositionX) < 45 Then
                    Sel(I).PositionX = S.PositionX
                    Changed = True
                    Exit For
                End If
            End If
        Next
    Next
    Loop While Changed
    
    ReDim St(1)
    St(1).Add Sel(1)
    For I = 2 To Sel.Count
        Finded = False
        For U = 1 To UBound(St)
            If Sel(I).PositionX = St(U)(1).PositionX Then
                St(U).Add Sel(I)
                Finded = True
                Exit For
            End If
        Next
        If Not Finded Then
            ReDim Preserve St(UBound(St) + 1)
            St(UBound(St)).Add Sel(I)
        End If
    Next
    
    Do
        Changed = False
        For I = 1 To UBound(St) - 1
            If St(I)(1).PositionX > St(I + 1)(1).PositionX Then
                Set Tmp = St(I)
                Set St(I) = St(I + 1)
                Set St(I + 1) = Tmp
                Changed = True
                Exit For
            End If
        Next
    Loop While Changed
    
    For I = 1 To UBound(St)
        Do
        Changed = False
            For U = 1 To St(I).Count - 1
                If St(I)(U).PositionY > St(I)(U + 1).PositionY Then
                    Set S = St(I)(U)
                    St(I).Remove U
                    St(I).Add S
                    Changed = True
                    Exit For
                End If
            Next
        Loop While Changed
    Next
    
    For I = 1 To UBound(St)
        For U = 1 To St(I).Count - 1
            A = St(I)(U).PositionY + St(I)(U).SizeHeight / 2
            St(I)(U + 1).PositionY = A + St(I)(U + 1).SizeHeight / 2
        Next
        
        If I <> 1 Then
            A = St(I - 1).PositionX + St(I - 1).SizeWidth / 2
            St(I).PositionX = A + St(I).SizeWidth / 2
            St(I).PositionY = St(I - 1).PositionY
        End If
    Next
    
End Sub

А как сюда метки влепить?
 
Ответ: Макрос для ХЗ для сборки визиток

В принципе уже сам разобрался и дописал расстановку меток, всем помогавшим спасибо.
 
Ответ: Макрос для ХЗ для сборки визиток

Ну вот видишь ;)

P.S. А таки вумную оптимизацию хочу...
А то приносят какие менеджеры расклад...
5 этикеток 10x20, 8 этикеток 5x10, 4 этикетки 3x30
(размеры условные)...
А ты идёшь и думаешь, как это все разместить на печатном листе...
Причём эта ж собака разложила. А вот схемку нарисовать, это как-бы ломы.
 
Ответ: Макрос для ХЗ для сборки визиток


Не по теме:
JAW, заходи ко мне в аську или личку, обсудим тему на системном уровне. Эл. почту не советую - она адресует на домашний ящик, где меня нет в данный момент.
 
Ответ: Макрос для ХЗ для сборки визиток

Очень бы хотелось иметь такой макрос для визиток, в документе есть сгрупированые обьекты 90x50, и макрос их раставляет на A3, с метками было б вообще шикарно. Может кто подскажет где есть такой или код отпишет, уверен это многим нужно и автор снискает славу и о нем будут ходить легенды как об избавителе дизайнеров или печатников от раскладки визиток.
 
Статус
Закрыто для дальнейших ответов.
Верх Низ