[CDR 2024] Помогите подправить макрос "Вставка лого"

[Chiga]

Не стоит поощрять говнокод, даже если он случайно работает правильно!

Ну так человек и просит помощи.

 

[zollinger]

Эта штука вообще должна работать не особо стабильно, из-за Copy-paste и переключения активных окон, оно в Кореле не особо синхронизировано

 

[_MBK_]

Ну так человек и просит помощи.

Человек приносит тебе тухлую рыбу и просит выковырять из нее червяков. Можно, конечно, дать ему свежую рыбу, но правильнее - удочку.

 

[zollinger]

ну дай, не вопрос

 

[zollinger]

Там сама идея порочна технологически, но какой смысл нам это обсуждать?

 

[Jeine]

Там сама идея порочна технологически, но какой смысл нам это обсуждать?

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

Что мешает перестать бороться с ветряными мельницами и начать верстать в программе, специально для этого предназначенной?

 

[Emergency]

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

 

[zollinger]

Что мешает перестать бороться с ветряными мельницами и начать верстать в программе, специально для этого предназначенной?

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

 

[Jeine]

Тогда надо просто предложить кактус на завтрак.

 

[_MBK_]

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

 

[Emergency]

Вы меня неправильно поняли - это было не про решение, а про целеполагание.

 

[zollinger]

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

 

[_MBK_]

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

Давай, может, подождем фидбэка от топикстартера? А то лично я до конца так и не понял, для чего именно ему такой странный говнокод, а все наперегонки бросились додумывать хотелку.

 

[zollinger]

Да а чего его ждать? Уже все равно сделано
Я там, правда. забыл слой его активировать "General" и сохранение не сделал (потому что зачем мне на своем компе такие приключения? Вот в этом архиве доделано.
И для ТСа - выделяешь лого там или еще чего и запускаешься, не нужно ничего копировать в клипбоард. Исходный файл модифицирован и сохранен не будет

 

[_MBK_]

Да а чего его ждать? Уже все равно сделано
Я там, правда. забыл слой его активировать "General" и сохранение не сделал (потому что зачем мне на своем компе такие приключения? Вот в этом архиве доделано.
И для ТСа - выделяешь лого там или еще чего и запускаешься, не нужно ничего копировать в клипбоард. Исходный файл модифицирован и сохранен не будет

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

 

[zollinger]

а, и у него же должно работать, только если слой Logo уже существует... Ну ладно, спросит - дадим

Ты ж не только для ТС код пишешь (точнее, больше для народного хозяйства и широкой общественности, чем для него) Так зачем тогда ты его в приаттаченные бинарники прячешь

Это zip-архивы в соответствии правилами форума, внутри файл .bas , от текстовый. В ответ вставлять код странно, там 150 строк, кому это нужно?

прятать его негоже.

Я тебя умоляю Если бы я хотел что-то спрятать, я бы просто ничего не делал
Вот, прикладываю это с последними прям правками, чтобы рабтало, только когда слой Logo уже существует. Очень удобно?

Attribute VB_Name = "ReplaceLogo"
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub ReplaceLogoInAllDocuments()

    Const DELAY_MS As Long = 500

    Dim origDoc As Document
    Dim sr As ShapeRange
    Dim tempFilePath As String
    Dim origLeft As Double, origTop As Double
    Dim doc As Document
    Dim processedDocs As New Collection
    Dim modifiedDocs As New Collection
    Dim logoLayer As Layer
    Dim generalLayer As Layer
    Dim importedShapes As ShapeRange
    Dim i As Integer
    Dim saveOptions As StructSaveAsOptions
    Dim report As String
    Dim d As Document
    Dim alreadyProcessed As Boolean
    Dim layerExists As Boolean

    ' --- Проверка выделения ---
    If ActiveSelectionRange.Count = 0 Then
        MsgBox "Выделите объект(ы) для использования в качестве логотипа.", vbExclamation
        Exit Sub
    End If

    Set origDoc = ActiveDocument
    Set sr = ActiveSelectionRange

    origLeft = sr.LeftX
    origTop = sr.TopY

    tempFilePath = Environ("TEMP") & "\CorelTempLogo_" & Format(Now, "yyyymmdd_hhnnss") & ".cdr"

    ' Сохраняем ТОЛЬКО выделение
    origDoc.Activate
    DoEvents
    Sleep DELAY_MS

    Set saveOptions = CreateStructSaveAsOptions()
    With saveOptions
        .Range = cdrSelection
        .Overwrite = True
        .IncludeCMXData = False
        .KeepAppearance = True
        .Version = cdrCurrentVersion
    End With

    On Error GoTo ErrorHandler
    origDoc.SaveAs tempFilePath, saveOptions

    ' --- Обработка всех остальных документов ---
    For Each doc In Documents
        If doc Is origDoc Then GoTo NextDoc

        ' Защита от повторной обработки
        alreadyProcessed = False
        For Each d In processedDocs
            If d Is doc Then
                alreadyProcessed = True
                Exit For
            End If
        Next d
        If alreadyProcessed Then GoTo NextDoc
        processedDocs.Add doc

        doc.Activate
        DoEvents
        Sleep DELAY_MS

        ' === Проверка: существует ли слой "Logo"? ===
        layerExists = False
        For i = 1 To doc.ActivePage.Layers.Count
            If doc.ActivePage.Layers(i).Name = "Logo" Then
                layerExists = True
                Exit For
            End If
        Next i

        If Not layerExists Then GoTo NextDoc

        ' === Удаляем слой "Logo" (сначала разблокируем!) ===
        For i = doc.ActivePage.Layers.Count To 1 Step -1
            If doc.ActivePage.Layers(i).Name = "Logo" Then
                doc.ActivePage.Layers(i).Editable = True  ' < РАЗБЛОКИРУЕМ
                doc.ActivePage.Layers(i).Delete
                DoEvents
                Sleep DELAY_MS
                Exit For
            End If
        Next i

        ' === Создаём новый слой "Logo" ===
        Set logoLayer = doc.ActivePage.CreateLayer("Logo")
        logoLayer.Editable = True
        DoEvents
        Sleep DELAY_MS

        ' === Импорт логотипа ===
        logoLayer.Import tempFilePath
        DoEvents
        Sleep DELAY_MS

        Set importedShapes = ActiveSelectionRange
        If importedShapes.Count = 0 Then GoTo NextDoc

        ' Позиционирование
        importedShapes.SetPosition origLeft, origTop
        DoEvents
        Sleep DELAY_MS

        ' Блокировка слоя
        logoLayer.Editable = False
        DoEvents
        Sleep DELAY_MS

        ' === Активируем слой "General" ===
        Set generalLayer = Nothing
        For i = 1 To doc.ActivePage.Layers.Count
            If doc.ActivePage.Layers(i).Name = "General" Then
                Set generalLayer = doc.ActivePage.Layers(i)
                Exit For
            End If
        Next i

        If Not generalLayer Is Nothing Then
            generalLayer.Activate
            DoEvents
            Sleep DELAY_MS
        End If

        ' === Сохраняем документ, если он уже имеет имя ===
        If doc.FileName <> "" Then
            doc.Save
            DoEvents
            Sleep DELAY_MS
        End If

        modifiedDocs.Add doc

NextDoc:
    Next doc

    ' Возврат к исходному документу
    origDoc.Activate
    DoEvents
    Sleep DELAY_MS

    ' Удаление временного файла
    If Dir(tempFilePath) <> "" Then Kill tempFilePath

    ' === Отчёт ===
    If modifiedDocs.Count = 0 Then
        report = "Ни один документ не содержит слой 'Logo' или не был изменён."
    Else
        report = "Логотип обновлён и документы сохранены:" & vbCrLf & vbCrLf
        For Each d In modifiedDocs
            If d.FileName <> "" Then
                report = report & d.FileName & vbCrLf
            Else
                report = report & "[" & d.Name & "] (не сохранён на диск)" & vbCrLf
            End If
        Next d
    End If

    MsgBox report, vbInformation, "Результат выполнения"
    Exit Sub

ErrorHandler:
    MsgBox "Ошибка: " & Err.Description & " (№" & Err.Number & ")", vbCritical
    On Error Resume Next
    If Dir(tempFilePath) <> "" Then Kill tempFilePath
End Sub

 

[Jeine]

Очень удобно?

 

[_MBK_]

Очень удобно?

 

[Drawer]

а, и у него же должно работать, только если слой Logo уже существует... Ну ладно, спросит - дадим

Это zip-архивы в соответствии правилами форума, внутри файл .bas , от текстовый. В ответ вставлять код странно, там 150 строк, кому это нужно?

Я тебя умоляю Если бы я хотел что-то спрятать, я бы просто ничего не делал
Вот, прикладываю это с последними прям правками, чтобы рабтало, только когда слой Logo уже существует. Очень удобно?

Attribute VB_Name = "ReplaceLogo"
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub ReplaceLogoInAllDocuments()

    Const DELAY_MS As Long = 500

    Dim origDoc As Document
    Dim sr As ShapeRange
    Dim tempFilePath As String
    Dim origLeft As Double, origTop As Double
    Dim doc As Document
    Dim processedDocs As New Collection
    Dim modifiedDocs As New Collection
    Dim logoLayer As Layer
    Dim generalLayer As Layer
    Dim importedShapes As ShapeRange
    Dim i As Integer
    Dim saveOptions As StructSaveAsOptions
    Dim report As String
    Dim d As Document
    Dim alreadyProcessed As Boolean
    Dim layerExists As Boolean

    ' --- Проверка выделения ---
    If ActiveSelectionRange.Count = 0 Then
        MsgBox "Выделите объект(ы) для использования в качестве логотипа.", vbExclamation
        Exit Sub
    End If

    Set origDoc = ActiveDocument
    Set sr = ActiveSelectionRange

    origLeft = sr.LeftX
    origTop = sr.TopY

    tempFilePath = Environ("TEMP") & "\CorelTempLogo_" & Format(Now, "yyyymmdd_hhnnss") & ".cdr"

    ' Сохраняем ТОЛЬКО выделение
    origDoc.Activate
    DoEvents
    Sleep DELAY_MS

    Set saveOptions = CreateStructSaveAsOptions()
    With saveOptions
        .Range = cdrSelection
        .Overwrite = True
        .IncludeCMXData = False
        .KeepAppearance = True
        .Version = cdrCurrentVersion
    End With

    On Error GoTo ErrorHandler
    origDoc.SaveAs tempFilePath, saveOptions

    ' --- Обработка всех остальных документов ---
    For Each doc In Documents
        If doc Is origDoc Then GoTo NextDoc

        ' Защита от повторной обработки
        alreadyProcessed = False
        For Each d In processedDocs
            If d Is doc Then
                alreadyProcessed = True
                Exit For
            End If
        Next d
        If alreadyProcessed Then GoTo NextDoc
        processedDocs.Add doc

        doc.Activate
        DoEvents
        Sleep DELAY_MS

        ' === Проверка: существует ли слой "Logo"? ===
        layerExists = False
        For i = 1 To doc.ActivePage.Layers.Count
            If doc.ActivePage.Layers(i).Name = "Logo" Then
                layerExists = True
                Exit For
            End If
        Next i

        If Not layerExists Then GoTo NextDoc

        ' === Удаляем слой "Logo" (сначала разблокируем!) ===
        For i = doc.ActivePage.Layers.Count To 1 Step -1
            If doc.ActivePage.Layers(i).Name = "Logo" Then
                doc.ActivePage.Layers(i).Editable = True  ' < РАЗБЛОКИРУЕМ
                doc.ActivePage.Layers(i).Delete
                DoEvents
                Sleep DELAY_MS
                Exit For
            End If
        Next i

        ' === Создаём новый слой "Logo" ===
        Set logoLayer = doc.ActivePage.CreateLayer("Logo")
        logoLayer.Editable = True
        DoEvents
        Sleep DELAY_MS

        ' === Импорт логотипа ===
        logoLayer.Import tempFilePath
        DoEvents
        Sleep DELAY_MS

        Set importedShapes = ActiveSelectionRange
        If importedShapes.Count = 0 Then GoTo NextDoc

        ' Позиционирование
        importedShapes.SetPosition origLeft, origTop
        DoEvents
        Sleep DELAY_MS

        ' Блокировка слоя
        logoLayer.Editable = False
        DoEvents
        Sleep DELAY_MS

        ' === Активируем слой "General" ===
        Set generalLayer = Nothing
        For i = 1 To doc.ActivePage.Layers.Count
            If doc.ActivePage.Layers(i).Name = "General" Then
                Set generalLayer = doc.ActivePage.Layers(i)
                Exit For
            End If
        Next i

        If Not generalLayer Is Nothing Then
            generalLayer.Activate
            DoEvents
            Sleep DELAY_MS
        End If

        ' === Сохраняем документ, если он уже имеет имя ===
        If doc.FileName <> "" Then
            doc.Save
            DoEvents
            Sleep DELAY_MS
        End If

        modifiedDocs.Add doc

NextDoc:
    Next doc

    ' Возврат к исходному документу
    origDoc.Activate
    DoEvents
    Sleep DELAY_MS

    ' Удаление временного файла
    If Dir(tempFilePath) <> "" Then Kill tempFilePath

    ' === Отчёт ===
    If modifiedDocs.Count = 0 Then
        report = "Ни один документ не содержит слой 'Logo' или не был изменён."
    Else
        report = "Логотип обновлён и документы сохранены:" & vbCrLf & vbCrLf
        For Each d In modifiedDocs
            If d.FileName <> "" Then
                report = report & d.FileName & vbCrLf
            Else
                report = report & "[" & d.Name & "] (не сохранён на диск)" & vbCrLf
            End If
        Next d
    End If

    MsgBox report, vbInformation, "Результат выполнения"
    Exit Sub

ErrorHandler:
    MsgBox "Ошибка: " & Err.Description & " (№" & Err.Number & ")", vbCritical
    On Error Resume Next
    If Dir(tempFilePath) <> "" Then Kill tempFilePath
End Sub

Настрочил, больше чем нейросеть... Теперь читать всё это

 

[Chiga]

Вот, прикладываю это с последними прям правками, чтобы рабтало, только когда слой Logo уже существует. Очень удобно?

говнокод

ТСа из 20 строк тоже работает )