Макросы VBA в CorelDraw. Экспортировать текущий выбор - PullRequest
Новая
       60

Макросы VBA в CorelDraw. Экспортировать текущий выбор

1 голос
/ 03 февраля 2020

Всем!

Я работаю над макросами, которые должны выбрать cdrBitmapShape и сохранить его как отдельный файл.

Я уже выяснил, как искать и выбирать такой объект, но я запустил в проблему его сохранения.

Я не понимаю, как мне сохранить выбранное изображение, это совершенно непонятно из документов.

Как я понимаю из здесь Я должен как-то назначить переменной Document текущий элемент выбора и экспортировать его.

Здесь - это тестовый файл

Как я могу это сделать? 

Sub Findall_bit_map()

    ' Recorded 03.02.2020
    'frmFileConverter.Start
    'Dim d As Document
    Dim retval As Long
    Dim opt As New StructExportOptions

    opt.AntiAliasingType = cdrNormalAntiAliasing
    opt.ImageType = cdrRGBColorImage
    opt.ResolutionX = 600
    opt.ResolutionY = 600

    Dim pal As New StructPaletteOptions
    pal.PaletteType = cdrPaletteOptimized
    pal.NumColors = 16
    pal.DitherType = cdrDitherNone
    Dim Filter As ExportFilter
    Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
    For Each shpCheck In OrigSelection

    re = shpCheck.Type
    If shpCheck.Type = cdrBitmapShape Then
        retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
        shpCheck.AddToSelection
        Set Filter = Document.ExportBitmap("D:\some.jpg", cdrJPEG)
        If Filter.ShowDialog() Then
            Filter.Finish
        Else
          MsgBox "Export canceled"
        End If
    End If
    Next shpCheck
    retval = MsgBox("Click OK if you agree.", vbOKCancel, "Easy Message")
    'ActivePage.Shapes.FindShapes(Query:="@type='BitmapShape'")
    If retval = vbOK Then
        MsgBox "You clicked OK.", vbOK, "Affirmative"
    End If

End Sub

1 Ответ

0 голосов
/ 05 февраля 2020

Я не знаю, где была ошибка, но вот рабочая версия. 

Sub Findall_bit_map_snip()

    Dim retval As Long
    Dim doc As Document

    Dim pal As New StructPaletteOptions
    pal.PaletteType = cdrPaletteOptimized
    pal.ColorSensitive = True

    pal.NumColors = 300000000
    pal.DitherType = cdrDitherNone

    Dim Filter As ExportFilter
    Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
    For Each shpCheck In OrigSelection
    Set doc = ActiveDocument
    doc.ClearSelection
    re = shpCheck.Type
    If shpCheck.Type = cdrBitmapShape Then
        retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
        shpCheck.AddToSelection
        Set Filter = doc.ExportBitmap("D:\some.jpg", cdrJPEG, cdrSelection, , , , 600, 600, cdrNoAntiAliasing, , False, , , , pal)
        Filter.Finish
    End If
    Next shpCheck

End Sub
...