Fountain to bitmap in powerclip

[grzjanik]

Thanks Shelby.

Write me please if this can be rewrite code so that it acted under v. 12?
If it can be done, is attempting?
Maybe someone else has to struggle with this code?

Thank you very much in advance.

Yours.
~GrzJanik

[runflacruiser]

Hi.
I think this mod would do but I didn't test.

Sub GradientToPowerclip()
    Const dblEnlarge = 1
    Dim s As Shape, sDup As Shape
    Dim sr As ShapeRange
    
    ActiveDocument.ReferencePoint = cdrCenter 'Set reference point to the center
    ActiveDocument.Unit = cdrMillimeter 'Set our unit to millimeters
    
    Set sr = ActivePage.Shapes.FindShapes()
    
    For Each s In sr.Shapes 'Loop thtough all the shapes found
        If s.Fill.Type = cdrFountainFill Then
            Set sDup = s.Duplicate 'Make a duplicate
            sDup.SetSize s.SizeWidth + dblEnlarge, s.SizeHeight + dblEnlarge 'Increase the size by our Constant
            sDup.Fill.Fountain.Steps = 999 'Set fountain fill steps to 999
            sDup.Outline.SetNoOutline 'Remove outline from duplice
            Set sDup = sDup.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True) 'Convert to Bitmap
            s.Fill.ApplyNoFill 'Remove fill from original shape
            sDup.AddToPowerClip s 'Place the bitmap in the orginal shape
        End If
    Next s
End Sub

~John

[grzjanik]

Thanks John.

Unfortunately does not work.
Errors shown below:





What to do about it now?

[runflacruiser]

Hi.
That's what I get for not testing.
Sorry, I'm unable to spend more time on this at the moment.
Try this new mod of Shelby's code:

~John

Sub GradientToPowerclip()
    Const dblEnlarge = 1
    Dim s As Shape, sDup As Shape
    Dim sr As ShapeRange
    
    ActiveDocument.ReferencePoint = cdrCenter 'Set reference point to the center
    ActiveDocument.Unit = cdrMillimeter 'Set our unit to millimeters
    
    Set sr = ActivePage.Shapes.FindShapes()
    
    For Each s In sr 'Loop thtough all the shapes found
        If s.Fill.Type = cdrFountainFill Then
            Set sDup = s.Duplicate 'Make a duplicate
            sDup.SetSize s.SizeWidth + dblEnlarge, s.SizeHeight + dblEnlarge 'Increase the size by our Constant
            sDup.Fill.Fountain.Steps = 999 'Set fountain fill steps to 999
            'sDup.Outline.SetNoOutline 'Remove outline from duplice
            Set sDup = sDup.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True) 'Convert to Bitmap
            s.Fill.ApplyNoFill 'Remove fill from original shape
            sDup.AddToPowerClip s 'Place the bitmap in the orginal shape
        End If
    Next s
End Sub

[grzjanik]

Hello!
Boys You are great.
The code works in Corel 12 after a small change.
Big thank you for your time and willingness.
The following valid code:

Sub GradientToPowerclipAll()
Const dblEnlarge = 1
Dim s As Shape, sDup As Shape
Dim sr As ShapeRange

ActiveDocument.ReferencePoint = cdrCenter 'Set reference point to the center
ActiveDocument.Unit = cdrMillimeter 'Set our unit to millimeters

Set sr = ActivePage.Shapes.FindShapes()

For Each s In sr 'Loop thtough all the shapes found
If s.Fill.Type = cdrFountainFill Then
Set sDup = s.Duplicate 'Make a duplicate
sDup.SetSize s.SizeWidth + dblEnlarge, s.SizeHeight + dblEnlarge 'Increase the size by our Constant
sDup.Fill.Fountain.Steps = 999 'Set fountain fill steps to 999
sDup.Outline.SetProperties 0# 'Remove outline from duplice
Set sDup = sDup.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True) 'Convert to Bitmap
s.Fill.ApplyNoFill 'Remove fill from original shape
sDup.AddToPowerClip s 'Place the bitmap in the orginal shape
End If
Next s
End Sub

Best regards.
~GrzJanik

[grzjanik]

Hi.
I noticed that the code works only on the current page.
If you can help convert him to work on the entire document (the groups, powerclips, all pages).
Thank you and best regards.
~GrzJanik