- Сообщения
- 21
- Реакции
- 1
Доброго времени суток. Ищу, подсказку, как оптимизировать массовою вставку в PowerClip?
Задача у меня следующая: есть страница, на ней находятся около 320 PowerClip разного размера и есть исходный файл определенного размера (594х841), необходимо взять исходный файл, перебрать в цикле все PowerClip с таким же размером (594х841) и вставить в них исходный файл.
Макрос написал, но при большом количестве вставляемых файлов он зависает, причем конкретно. Тесты показали, что если на странице не больше 40 файлов - все работает, но как только подсунуть ему больше - зависает.
Что можете подсказать?
Задача у меня следующая: есть страница, на ней находятся около 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)
Последнее редактирование: