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

Статус
Закрыто для дальнейших ответов.
W

wakh

Топикстартер
10 лет на форуме
Сообщения
146
Реакции
2
Подлинковывает пучок битмапов, описание работы ниже.
Код: 
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 - блог о веб разработке
 
То ли я такой тупой, но не пойму, чем создавать какие то непонятные текстовые файлы, не проще ли при импорте выделить хоть весь каталог - накидает с таким же успехом? 'hmmm'
 
импорт != линк

В макросе была глупая ошибка - вот рабочая версия
Код: 
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
 
wakh сказал(а):
импорт != линк
Нажмите, чтобы раскрыть...
При импорте можно выбрать импорт с линковкой (в новых версиях стрелка вниз на кнопке импорта, в старых просто опцией)
по макросу - можно было импортировать сразу по мере чтения строк из файла не заводя массив
 
lev сказал(а):
в старых просто опцией
Нажмите, чтобы раскрыть...
Там как только несколько выбираешь опция серой становится.
Идея с текстовым файлом мне кажется порочной, IMHO как то можно создать файловый диалог с множественным выбором? В офисном VBA, вроде как точно можно
 
Угу, а в новых серым не становится, но и импортирует без линка.
А файловый диалог легко выискивается в нете.
 
Делал для себя, в порыве решения конкретной задачи и мне удобно текстовый файл, хотя прикрутить диалог можно, но мне это не нужно, а большинство считают линковку в кореле вообще за гранью добра. Неудобство выбора в диалоге возникнет если картинки в разных каталогах, хотя этого быть не должно - их крайне желательно предварительно сложить/залинковать (я про "симлинки") в 1 каталог.
 
lev сказал(а):
Угу, а в новых серым не становится, но и импортирует без линка.
А файловый диалог легко выискивается в нете.
Нажмите, чтобы раскрыть...
Х7 достаточно новый? всё становится серым, как всегда. Вопрос почему или даже зачем я даже не берусь задавать.
 
wakh сказал(а):
Делал для себя
Нажмите, чтобы раскрыть...
wakh сказал(а):
мне удобно
Нажмите, чтобы раскрыть...
wakh сказал(а):
мне это не нужно
Нажмите, чтобы раскрыть...
Тогда вообще не пойму, с какой целью выкладывали неудобный и практически бесполезный для всех макрос? Ну я как то мог понять бы, если бы это был костыль, позволяющий размножить опцию линковки на несколько файлов, но чудовищное неудобство составления текстового файла с полными путями к каждому файлу делает данный макрос полностью не функциональным для широкого потребителя.
 
При выбранном фильтре импорта растровых файлов, например, tiff, серым не становится, но и линка не происходит.
 
lev сказал(а):
При импорте можно выбрать импорт с линковкой (в новых версиях стрелка вниз на кнопке импорта, в старых просто опцией)
по макросу - можно было импортировать сразу по мере чтения строк из файла не заводя массив
Нажмите, чтобы раскрыть...
если бы я писал на знакомом мне языке, возможно, но раз уж сделал так скажите, это нормально?
Код: 
    i = 0
    While Not EOF(1)
        ReDim Preserve arr(i + 1)
        Line Input #1, arr(i)
        i = i + 1
   Wend
после PHP мне кажется этот код избыточным
 
_MBK_ сказал(а):
Тогда вообще не пойму, с какой целью выкладывали неудобный и практически бесполезный для всех макрос? Ну я как то мог понять бы, если бы это был костыль, позволяющий размножить опцию линковки на несколько файлов, но чудовищное неудобство составления текстового файла с полными путями к каждому файлу делает данный макрос полностью не функциональным для широкого потребителя.
Нажмите, чтобы раскрыть...
Мне искренне кажется этот макрос удобным, а главное, очень полезным. Есть вероятность, что я не один такой, остальные могут его не использовать, это не налог и не воинская обязанность.
 
lev сказал(а):
При выбранном фильтре импорта растровых файлов, например, tiff, серым не становится, но и линка не происходит.
Нажмите, чтобы раскрыть...
я так понял речь идёт о
Код: 
 Set impflt = ActiveLayer.ImportEx(file1, cdrTIFF, impopt)
тут я не разбирался - это взято из записи макроса, мало того я даже удивился, но JPG, втянулось
 
wakh сказал(а):
после PHP мне кажется этот код избыточным
Нажмите, чтобы раскрыть...
Естественно, он избыточен, вам же Лев уже сказал, что два цикла тут вовсе не требуется - одним обойтись можно
 
можно объявить массив сразу на сотню значений и наращивать на сотню проверяя счетчик на достижение границы
но я уже советовал обойтись без массива
заодно обратите внимание на проверку существования файла
Код: 
  Set fs = CreateObject("Scripting.FileSystemObject")
  While Not EOF(1)
  Line Input #1, file1
  If fs.FileExists(file1) Then  .
  Wend
 
В ПХП, я просто кидал в архив новое значение и массив сам рос, здесь, увы нужно самому увеличивать. собственно этот вопрос для саморазвития.
А вот мысль с проверкой на существование архиважная, спасибо за готовое решение.
 
Код: 
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
 
wakh сказал(а):
Вот эти строки закоментил я, зря?
Нажмите, чтобы раскрыть...
Почему зря?
Не нужны они
И тем не менее, сделайте выбор файлов из диалога, никто возиться с текстовиками не будет никогда
 
Вы это говорите как потенциальный пользователь или метафизически?
Я "вожусь с текстовиками" при печати с подстановкой, а теперь вот и с линковкой - мне это кажется очень удобным. Вообще мечтаю о полиграфии на HTML+CSS.
Если диалоги кому-то будут реально нужны - попробую сделать по-возможности, увы мои знания VBA, недалеки от "Hello world".
 
Зачем оставили проверку If file1 <> "" Then ... ? Считаете FileExists решит, что такой файл существует?
MsgBox "File " & file1 & " not found" в цикле - есть вероятность десятка сообщений о несуществовании, лучше собирать данные файлы в текстовую переменную, продолжая импорт, а потом выдать одним сообщением весь список несуществующих. Или, сначала, в цикле проверить существование - ругнуться списком, а затем предложить импортировать существующие или совсем отказаться от импорта.
 
Статус
Закрыто для дальнейших ответов.
Верх Низ
Назад