[CDR 2017-2021] Vba макрос - вставка в PowerClip

serega.pte · 10.07.2018

Доброго времени суток. Ищу, подсказку, как оптимизировать массовою вставку в PowerClip?
Задача у меня следующая: есть страница, на ней находятся около 320 PowerClip разного размера и есть исходный файл определенного размера (594х841), необходимо взять исходный файл, перебрать в цикле все PowerClip с таким же размером (594х841) и вставить в них исходный файл.

Макрос написал, но при большом количестве вставляемых файлов он зависает, причем конкретно. Тесты показали, что если на странице не больше 40 файлов - все работает, но как только подсунуть ему больше - зависает.
Что можете подсказать?

Код:

ActiveDocument.Unit = cdrMillimeter
    Set sr = ActiveSelectionRange
    sr.Copy
    Dim pasteopt As StructPasteOptions
    Set pasteopt = CreateStructPasteOptions
    With pasteopt.ColorConversionOptions
        .SourceColorProfileList = "sRGB IEC61966-2.1,Coated FOGRA39 (ISO 12647-2:2004),Dot Gain 15%"
        .TargetColorProfileList = "sRGB IEC61966-2.1,Coated FOGRA39 (ISO 12647-2:2004),Dot Gain 15%"
    End With
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveLayer.PasteEx(pasteopt)
    WObject = Round(Paste1.SizeWidth) 'Вычисляю ширину исходного файла
    HObject = Round(Paste1.SizeHeight) 'Вычисляю высоту исходного файла
    Set PageObject = ActivePage
    For Each PwcObj In PageObject.Shapes
        Set pwc = Nothing
        On Error Resume Next
        Set pwc = PwcObj.PowerClip
        On Error GoTo 0
            If Not pwc Is Nothing Then
                W = Round(PwcObj.SizeWidth) ' Вычисляю ширину PowerClip
                H = Round(PwcObj.SizeHeight) ' Вычисляю высоту PowerClip
               ' Если ширина и высота исходника сошлась с шириной и высотой PowerClip
                If W = WObject And H = HObject Then
                    Set Paste1 = ActiveLayer.PasteEx(pasteopt)  ' Отладчик зависает здесь после 40 итерации цикла
                    Paste1.AddToPowerClip PwcObj
                    count = count + 1
                End If
             End If
    Next PwcObj
    Clipboard.Clear
    MsgBox (count)

serega.pte · 10.07.2018

Простите, вставил не весь код. Забыл указать тип переменных используемых в коде макроса.

Код:

Dim sr As ShapeRange
 Dim PwcObj As Shape, PwcObjectAll As Shape
 Dim count As Integer
 Dim pwc As PowerClip
 Dim W As String, H As String, IndName As String
 Dim WObject As String, HObject As String
ActiveDocument.Unit = cdrMillimeter
   Set sr = ActiveSelectionRange
   sr.Copy
   Dim pasteopt As StructPasteOptions
   Set pasteopt = CreateStructPasteOptions
   With pasteopt.ColorConversionOptions
       .SourceColorProfileList = "sRGB IEC61966-2.1,Coated FOGRA39 (ISO 12647-2:2004),Dot Gain 15%"
       .TargetColorProfileList = "sRGB IEC61966-2.1,Coated FOGRA39 (ISO 12647-2:2004),Dot Gain 15%"
   End With
   Dim Paste1 As ShapeRange
   Set Paste1 = ActiveLayer.PasteEx(pasteopt)
   WObject = Round(Paste1.SizeWidth) 'Вычисляю ширину исходного файла
   HObject = Round(Paste1.SizeHeight) 'Вычисляю высоту исходного файла
   Set PageObject = ActivePage
   For Each PwcObj In PageObject.Shapes
       Set pwc = Nothing
       On Error Resume Next
       Set pwc = PwcObj.PowerClip
       On Error GoTo 0
           If Not pwc Is Nothing Then
               W = Round(PwcObj.SizeWidth) ' Вычисляю ширину PowerClip
               H = Round(PwcObj.SizeHeight) ' Вычисляю высоту PowerClip
              ' Если ширина и высота исходника сошлась с шириной и высотой PowerClip
               If W = WObject And H = HObject Then
                   Set Paste1 = ActiveLayer.PasteEx(pasteopt)  ' Отладчик зависает здесь после 40 итерации цикла
                   Paste1.AddToPowerClip PwcObj
                   count = count + 1
               End If
            End If
   Next PwcObj
   Clipboard.Clear
   MsgBox (count)

Очень надеюсь на подсказку Гуру, так как уже третий день парюсь и все без толку.

_MBK_ · 11.07.2018

Какой то безумный индусский код.
Я правильно понимаю, он дублирует объекты на странице через Copy-PasteEx? Зачем такой странный глючный костыль?
И еще - вы перебираете все объекты на странице, непрерывно добавляя новые. Вам не кажется это похожим на попытку вычерпать море ложкой, выливая воду в него же?

serega.pte · 11.07.2018

_MBK_ сказал(а):
Какой то безумный индусский код.
Я правильно понимаю, он дублирует объекты на странице через Copy-PasteEx? Зачем такой странный глючный костыль?
И еще - вы перебираете все объекты на странице, непрерывно добавляя новые. Вам не кажется это похожим на попытку вычерпать море ложкой, выливая воду в него же?

Какой то безумный индусский код.
Я правильно понимаю, он дублирует объекты на странице через Copy-PasteEx? Зачем такой странный глючный костыль?

Да, я создаю копию исходного файла, а за тем в цикле ищу PowerClip нужного размера, после чего выполняю вставку в PowerClip.

Вам не кажется это похожим на попытку вычерпать море ложкой, выливая воду в него же?

Точно, я даже не подумал в эту сторону. Подскажите пожалуйста, как поступить в этой ситуации? Не пойму, как можно вставлять в PowerClip без дублирования объектов? Если не дублировать объекты, то вставляется только 1 объект в PowerClip, а остальные остаются пустыми.

dastin · 11.07.2018

это всё что вам потребуется

Код:

Sub Istchi()

Dim w As Double, h As Double, x As Double, y As Double
Dim pc As Shape, s0 As Shape, s1 As Shape, sr As ShapeRange

    ActiveDocument.ReferencePoint = cdrCenter
    ActiveDocument.Unit = cdrMillimeter

    Set s0 = ActiveShape
    s0.GetBoundingBox x, y, w, h
    Set sr = ActivePage.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
    For Each pc In sr
        If pc.SizeHeight = s0.SizeHeight And pc.SizeWidth = s0.SizeWidth Then
        Set s1 = s0.Duplicate
        s1.AddToPowerClip pc, -1
        End If
        Next pc
    
End Sub

копия выделенного файла запрыгнет в каждый из поверклипов на странице, если он будет точь в точь совпадать по размеру

dastin · 11.07.2018

да и
~~s0.GetBoundingBox x, y, w, h~~
там не нужен
так можно

Код:

    s0.GetSize w, h

serega.pte · 11.07.2018

dastin сказал(а):
это всё что вам потребуется

Код:

Sub Istchi() Dim w As Double, h As Double, x As Double, y As Double Dim pc As Shape, s0 As Shape, s1 As Shape, sr As ShapeRange ActiveDocument.ReferencePoint = cdrCenter ActiveDocument.Unit = cdrMillimeter Set s0 = ActiveShape s0.GetBoundingBox x, y, w, h Set sr = ActivePage.Shapes.FindShapes(Query:="!@com.powerclip.IsNull") For Each pc In sr If pc.SizeHeight = s0.SizeHeight And pc.SizeWidth = s0.SizeWidth Then Set s1 = s0.Duplicate s1.AddToPowerClip pc, -1 End If Next pc End Sub

копия выделенного файла запрыгнет в каждый из поверклипов на странице, если он будет точь в точь совпадать по размеру

Супер! Огромное спасибо! Все работает!
Сейчас буду разбирать код, очень много нового и интересного для себя увидел.

_MBK_ · 11.07.2018

Вот только рот хотел открыть, а дастин уже и код отладил

~RA~ · 11.07.2018

Не по теме:
Для каких целей сие?

dastin · 11.07.2018

ну можно и референс с юнитами убрать ...

для краткости

dastin · 11.07.2018

~RA~ сказал(а):
Для каких целей сие?

несколько сотен поверклипов и исходный файл размером (594х841)
это какова страница там? Но вопрос был не об этом. Он стоял - КАК?

serega.pte · 11.07.2018

dastin сказал(а):
несколько сотен поверклипов и исходный файл размером (594х841)
это какова страница там? Но вопрос был не об этом. Он стоял - КАК?

Если вкратце, то это рекламы для магазинов.
То есть, у каждого из 320 магазинов есть некий стенд определенного размера, куда каждый месяц нужно вставить рекламу.

Идея такова, дизайнер делает исходные файлы нужных размеров (594х841,930х1170 и так далее), а с помощью скрипта заполняет документ!
Далее следует следующий этап, нужно каждый PowerClip сохранить в TIFF формате и с определенным именем (размер_номр магазина), например 594х841_A41, 930x1170_A87 и так далее.
Эта часть кода уже готова, но это уже совсем другая история)

~RA~ · 11.07.2018

Очень, очень странный воркфлоу.

serega.pte · 11.07.2018

~RA~ сказал(а):
Очень, очень странный воркфлоу.

Согласен. Но придумано это не мной, мне лишь предстоит с этим бороться.
Просто удивляет сам факт, что на протяжении многих лет весь этот процесс делался работниками в ручную.
Я один раз попробовал сделать в ручную - чуть с ума не сошел.
Представляете, что в каждый PowerClip нужно вставить изображение нужного формата, а затем экспортировать в TIFF, указав имя файла с размером и номером магазина? Это тяжелая, монотонная работа!

~RA~ · 11.07.2018

А

serega.pte сказал(а):
изображение нужного формата

откуда берется?

_MBK_ · 11.07.2018

~RA~ сказал(а):
Очень, очень странный воркфлоу.

Почему нет?

~RA~ · 11.07.2018

_MBK_ сказал(а):
Почему нет?

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

_MBK_ · 11.07.2018

~RA~ сказал(а):
что либо этот этап тут лишний, либо, вообще, корел.

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

~RA~ · 11.07.2018

_MBK_ сказал(а):
почему бы и не?

Корел, тифф, много макетов в одном. Тебе не кажется, что что-то тут неправильно?
Но я дождусь ответа.

_MBK_ · 11.07.2018

serega.pte сказал(а):
дизайнер делает исходные файлы нужных размеров

В кореле ж делает. И что тут неправильного?

[CDR 2017-2021] Vba макрос - вставка в PowerClip

Участник

Участник

Пикирующий бомбардировщик

Участник

Некромант-любитель

Некромант-любитель

Участник

Пикирующий бомбардировщик

Одарённая.

Некромант-любитель

Некромант-любитель

Участник

Вложения

Одарённая.

Участник

Одарённая.

Пикирующий бомбардировщик

Одарённая.

Пикирующий бомбардировщик

Одарённая.

Пикирующий бомбардировщик