Массовая подлинковка картинок в Кореле - Макрос

В 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

Написано топорно, но работает!

Метки: ,

Leave a comment


Comment moderation is enabled on this site. This means that your comment will not be visible until it has been approved by an editor.