VBA, Свойства Bimap + Shaper

[Oleg_Sh]

Как в VBA макросе определить насколько битмап зарезан шейпером (Shape Tool)?

 

[banIDit]

Ответ: VBA, Свойства Bimap + Shaper

Что значит «насколько зарезан шейпером»? Может просто «зарезан»?

 

[Шарфюрер]

Ответ: VBA, Свойства Bimap + Shaper

Как определить насколько битмап зарезан шейпером (Shape Tool)?

Попробуй глянуть в режиме Wireframe, если я конечно правильно понял твой вопрос.

 

[lort]

Ответ: VBA, Свойства Bimap + Shaper

Попробуй глянуть в режиме Wireframe, если я конечно правильно понял твой вопрос.

А что покажет режим Wireframe?

 

[Oleg_Sh]

Ответ: VBA, Свойства Bimap + Shaper

Что значит «насколько зарезан шейпером»? Может просто «зарезан»?

Прошу прощения. Я имел ввиду Как с помощью VBA узнать насколько зарезан битмап.

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

Пожалуста, не предлагайте перейти на ID, PM, QP и др. Файлы чужие, а весь геморой мне.

 

[banIDit]

Ответ: VBA, Свойства Bimap + Shaper

Когда-то делал я модуль заменяющий в макете все Clipping path на Power Clip...
но посеял где-то. Надо у kerch спросить, ему давал потестить.

 

[kerch]

Ответ: VBA, Свойства Bimap + Shaper

Надо у kerch спросить, ему давал потестить.

Да, действительно, их есть у меня.
С позволения banIDit'a могу выложить на форум код.

 

[banIDit]

Ответ: VBA, Свойства Bimap + Shaper

Не возражаю.

 

[kerch]

Ответ: VBA, Свойства Bimap + Shaper

 Sub Crop_Power_Clip()
 
 
'############# Объявляем переменные #############

    Dim s As Shape
    Dim shs As Shapes
    Dim expflt As ExportFilter
    Dim expopt As StructExportOptions
    Dim impflt As ImportFilter
    Dim impopt As StructImportOptions
    Dim x As Double, y As Double, w As Double, h As Double, I As String, origN As String
    
    Set impopt = New StructImportOptions
    Set expopt = New StructExportOptions
    Set shs = ActiveSelection.Shapes
    
    
'############# Начинаем программу #############
    If shs.Count = 0 Then
        I = MsgBox("Будет обработана вся страница.", vbInformation + vbOKCancel, "Внимание!")
        If I = vbCancel Then End
    Set shs = ActivePage.Shapes: End If
        n = 1 'начало нумератора
    For Each s In shs ' для каждого шейпа цикл
        If s.Type = cdrBitmapShape Then ' условие выполнения
            If s.Bitmap.CropEnvelopeModified = True Then
            Set fs = CreateObject("Scripting.FileSystemObject") ' Создаем папку "вася"
            Set folder = fs.CreateFolder("c:\vasya\")            '
            origN = s.Name ' помещаем имя в переменную
        With s
            .Name = "vasya" & n ' задаем имя
            .CreateSelection
            .GetBoundingBox x, y, w, h, True 'снимаем размеры
            .Bitmap.Crop ' кропим картинку
            .Duplicate ' дублируем картинку
            .Bitmap.ConvertToBW cdrRenderLineArt, Threshold:=128 ' меняем цветовую модель
        End With
                    expopt.UseColorProfile = False ' экспорт
                    Set expflt = ActiveDocument.ExportEx("c:\vasya\vasya" & n & ".svg", cdrSVG, cdrSelection, expopt)
                    expflt.Finish
            ActiveSelection.Delete
                
                    With impopt ' импорт
                        .MaintainLayers = False
                        .CodePage = 1252
                    End With
                Set impflt = ActiveLayer.ImportEx("c:\vasya\vasya" & n & ".svg", cdrSVG, impopt)
                    impflt.Finish
                    folder.Delete ' удаляем папку вася
            
                ActiveShape.PowerClip.EnterEditMode ' редактируем Power Clip
                ActivePage.Shapes.All.Delete ' нужно все удалить внутри него
                ActiveShape.PowerClip.LeaveEditMode
        With ActiveSelection
                .SetBoundingBox x, y, w, h, True ' задаем размеры, убираем эффекты, и "нет" заливку
                .ClearEffect cdrLens
                .Fill.ApplyNoFill
        End With
                Set fs = ActivePage.FindShape(Name:="vasya" & n) ' находим шейп с именем и помещаем его в powerclip
                    ActiveShape.OrderFrontOf fs ' задаем нужный порядок в стопке
                    fs.Bitmap.ResetCropEnvelope ' сбрасываем обтравку у картинки
                    fs.AddToPowerClip ActiveShape ' помещаем ее в повер клип
                    ActiveShape.Name = origN ' возвращаем старое имя
        n = n + 1
            End If
        End If
    Next s
    
End Sub

 

[Oleg_Sh]

Ответ: VBA, Свойства Bimap + Shaper

Вот спасибо!
Буду посмотреть.

 

[banIDit]

Ответ: VBA, Свойства Bimap + Shaper

Возможно модуль сыроват, не отшлифован толком, но за основу пойдет.