Массовая подлинковка картинок в Кореле - Макрос
Posted on 08 Декабрь 2015 in Веб разработка by wakh
В CorelDraw существует возможность подлинковки картинок вместо импорта. Это упрощает работу с большими файлами. Очень. Однако реализовано это мягко говоря не очень. Для версий до 16 существует макрос BitmapLinksManager 1.0, который облегчает ряд задач, но в 17 версии он не работает. Если вам нужно импортировать много изображений путём подлинковки (place), то Ад становится не таким уж фантастическим местом. Для решение этой проблемы я сделал макрос. Подробности по катом.
ЗЫ
Немного про линки.
Для работы макроса необходимо создать текстовый файл со списком файлов для импорта.
Одно имя файла с полным путём на строку. Сохранить этот файл под тем же именем и в той же папке, что и редактируемый документ, но с расширением .txt вместо .cdr. Далее запустить макрос из документа. Он накидает все файлы на текущий слой. Работает быстро, 80 файлов импортнулись за 1-3 минуты.
' ver 0.3
Sub PlaceFromFile()
Dim impopt As StructImportOptions
Set impopt = CreateStructImportOptions
With impopt
.Mode = cdrImportFull
.LinkBitmapExternally = True
.MaintainLayers = True
' With .ColorConversionOptions
' .SourceColorProfileList = "sRGB IEC61966-2.1,Wide Gamut CMYK Simulation,Gray Gamma 2.2"
' .TargetColorProfileList = "sRGB IEC61966-2.1,Wide Gamut CMYK Simulation,Gray Gamma 2.2"
' End With
End With
Dim file$
file = ActiveDocument.FilePath & Replace(ActiveDocument.FileName, ".cdr", ".txt")
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(file) Then
Dim impflt As ImportFilter
Open file For Input As #1
While Not EOF(1)
Line Input #1, file1
If file1 <> "" Then
If fs.FileExists(file1) Then
Set impflt = ActiveLayer.ImportEx(file1, cdrTIFF, impopt)
impflt.Finish
Else
MsgBox "File " & file1 & " not found"
End If
End If
Wend
Close #1
Else
MsgBox "File " & file & " not found"
End If
' MsgBox
End Sub
Написано топорно, но работает!
