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

[wakh]

Подлинковывает пучок битмапов, описание работы ниже.

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")

    Open file For Input As #1
    Dim arr() As String
    i = 0
    ReDim Preserve arr(i + 1)
    While Not EOF(1)
        Line Input #1, arr(i)
        i = i + 1
    Wend
    Close #1
'   MsgBox arr(1)
    Dim impflt As ImportFilter
    For Each file1 In arr
        Set impflt = ActiveLayer.ImportEx(file1, cdrTIFF, impopt)
        impflt.Finish
    Next
End Sub

Для работы макроса необходимо создать текстовый файл со списком файлов для импорта. Сохранить этот файл под тем же именем и в той же папке, что и редактируемый документ, но с расширением .txt вместо .cdr.
Структура файла - Одно имя файла (который линкуем) с полным путём на строку.
Далее запустить макрос из документа. Он накидает все файлы на текущий слой. Работает быстро, 80 файлов импортнулись за 1-3 минуты.
ЗЫ
ссыль в бложике Массовая подлинковка картинок в Кореле - Макрос - Web Development blog - блог о веб разработке

 

[_MBK_]

То ли я такой тупой, но не пойму, чем создавать какие то непонятные текстовые файлы, не проще ли при импорте выделить хоть весь каталог - накидает с таким же успехом?

 

[wakh]

импорт != линк

В макросе была глупая ошибка - вот рабочая версия

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")
    Open file For Input As #1
    Dim arr() As String
    i = 0
    While Not EOF(1)
        ReDim Preserve arr(i + 1)
        Line Input #1, arr(i)
        i = i + 1
   Wend
    Close #1
    Dim impflt As ImportFilter
    For Each file1 In arr
    If file1 <> "" Then
        Set impflt = ActiveLayer.ImportEx(file1, cdrTIFF, impopt)
        impflt.Finish
    End If
    Next
'   MsgBox
End Sub

 

[lev]

импорт != линк

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

 

[_MBK_]

в старых просто опцией

Там как только несколько выбираешь опция серой становится.
Идея с текстовым файлом мне кажется порочной, IMHO как то можно создать файловый диалог с множественным выбором? В офисном VBA, вроде как точно можно

 

[lev]

Угу, а в новых серым не становится, но и импортирует без линка.
А файловый диалог легко выискивается в нете.

 

[wakh]

Делал для себя, в порыве решения конкретной задачи и мне удобно текстовый файл, хотя прикрутить диалог можно, но мне это не нужно, а большинство считают линковку в кореле вообще за гранью добра. Неудобство выбора в диалоге возникнет если картинки в разных каталогах, хотя этого быть не должно - их крайне желательно предварительно сложить/залинковать (я про "симлинки") в 1 каталог.

 

[wakh]

Угу, а в новых серым не становится, но и импортирует без линка.
А файловый диалог легко выискивается в нете.

Х7 достаточно новый? всё становится серым, как всегда. Вопрос почему или даже зачем я даже не берусь задавать.

 

[_MBK_]

Делал для себя

мне удобно

мне это не нужно

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

 

[lev]

При выбранном фильтре импорта растровых файлов, например, tiff, серым не становится, но и линка не происходит.

 

[wakh]

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

если бы я писал на знакомом мне языке, возможно, но раз уж сделал так скажите, это нормально?

    i = 0
    While Not EOF(1)
        ReDim Preserve arr(i + 1)
        Line Input #1, arr(i)
        i = i + 1
   Wend

после PHP мне кажется этот код избыточным

 

[wakh]

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

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

 

[wakh]

При выбранном фильтре импорта растровых файлов, например, tiff, серым не становится, но и линка не происходит.

я так понял речь идёт о

 Set impflt = ActiveLayer.ImportEx(file1, cdrTIFF, impopt)

тут я не разбирался - это взято из записи макроса, мало того я даже удивился, но JPG, втянулось

 

[_MBK_]

после PHP мне кажется этот код избыточным

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

 

[lev]

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

  Set fs = CreateObject("Scripting.FileSystemObject")
  While Not EOF(1)
  Line Input #1, file1
  If fs.FileExists(file1) Then  .
  Wend

 

[wakh]

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

 

[wakh]

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

Вот эти строки закоментил я, зря?

'        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

 

[_MBK_]

Вот эти строки закоментил я, зря?

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

 

[wakh]

Вы это говорите как потенциальный пользователь или метафизически?
Я "вожусь с текстовиками" при печати с подстановкой, а теперь вот и с линковкой - мне это кажется очень удобным. Вообще мечтаю о полиграфии на HTML+CSS.
Если диалоги кому-то будут реально нужны - попробую сделать по-возможности, увы мои знания VBA, недалеки от "Hello world".

 

[lev]

Зачем оставили проверку If file1 <> "" Then ... ? Считаете FileExists решит, что такой файл существует?
MsgBox "File " & file1 & " not found" в цикле - есть вероятность десятка сообщений о несуществовании, лучше собирать данные файлы в текстовую переменную, продолжая импорт, а потом выдать одним сообщением весь список несуществующих. Или, сначала, в цикле проверить существование - ругнуться списком, а затем предложить импортировать существующие или совсем отказаться от импорта.