Fountain to bitmap in powerclip

[grzjanik]

Hello everyone.

I need something like this:

1. Duplicate the curve in the same place.


2. Put the original to Powerclip and enlarge the curve about 1 mm.


3. Fountain Set by steps to 999.


4. Contents Powerclip converts the bitmap (CMYK, 300 dpi).


5. Exit from Powerclip.


I just have to replace all marked Fountains or the entire document.

Sometimes the need to replace all the complicated fountains to bitmaps because of differences Corel <> Adobe.

Thank you very much for your help.

Best Regards.

~GrzJanik

[grzjanik]

Hello members of Oberon.

I managed to do something like this:

Sub GradientToPowerclip()

ActiveDocument.Unit = cdrMillimeter
Dim x As Double, y As Double
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim s1 As Shape
Dim dup1 As ShapeRange
Set dup1 = OrigSelection.Duplicate()
OrigSelection.AddToPowerClip dup1(1)
dup1.ApplyNoFill
dup1(1).PowerClip.EnterEditMode
Dim s2 As Shape
Set s2 = OrigSelection.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True)
ActiveDocument.ReferencePoint = cdrCenter
OrigSelection.GetPosition x, y
s2.Stretch 1.02, 1.02
Dim s3 As Shape
Set s3 = s2.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True)
dup1(1).PowerClip.LeaveEditMode

End Sub

I can not clean up the code. I am a beginner in VBA. But it works.

I can not just do this change would affect all the selected gradients, or all throughout the document (in powerclips also).

Please send me an hint.

Regards.
~GrzJanik

[grzjanik]

Now the code looks like this:

Sub GradientToPowerclipWithFountain()

ActiveDocument.Unit = cdrMillimeter
Dim x As Double, y As Double
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim s1 As Shape
Dim dup1 As ShapeRange
Set dup1 = OrigSelection.Duplicate()
ActiveSelection.Fill.Fountain.Steps = 999
OrigSelection.AddToPowerClip dup1(1)
dup1.ApplyNoFill
dup1(1).PowerClip.EnterEditMode
Dim s2 As Shape

Set s2 = OrigSelection.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True)
ActiveDocument.ReferencePoint = cdrCenter
OrigSelection.GetPosition x, y
s2.Stretch 1.02, 1.02
Dim s3 As Shape
Set s3 = s2.ConvertToBitmapEx(cdrCMYKColorImage, False, False, 300, cdrNormalAntiAliasing, True)
dup1(1).PowerClip.LeaveEditMode

End Sub

Works and changes the fountain steps on 999!

How to do it throughout the document?

Yours beginner.
~GrzJanik

[grzjanik]

Unfortunately, it works but not always correctly.

[grzjanik]

It is a pity that no one attempted to solve the problem.

I think that either too difficult or for some reason active users do not like me (although I do not know why).

[shark]

Hi.
You could use loop For Each/Next to check all shapes on the page.
Then call your sub to process curve.
Something like...

Dim s As Shape
For Each s In ActivePage.FindShapes()
If (s.Type = cdrCurveShape) and (s.Fill.Type = cdrFountainFill) Then
GradientToPowerclipWithFountain(s)
End If
Next s

Sub GradientToPowerclipWithFountain(ByRef s as Shape)
...
replace old shape by new shape
...
End Sub

[grzjanik]

Hi Shark.

Thank you for your reply.

I will try to use your idea.
Write to know about the effects of my work.

I'm still a beginner so little I know and not everything goes to me.
Any help and useful idea to me.

Soon I will write what I did or a failure.

Thank you for your help.
I greet all the help.

~GrzJanik

[shelbym]

You did not say which version of CorelDRAW you are using, this code will only work on X4 and above as I use CQL to find the shapes with a fountain fill. Also, this code will only convert the ActivePage, if you want to do all pages in a document you would need to add another loop. Hope it helps:

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(Query:="@fill.type = 'fountain'") 'Find all shapes with fountain fills
    
    For Each s In sr.Shapes 'Loop thtough all the shapes found
        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
    Next s
End Sub

-Shelby

[grzjanik]

Hello.
Shelby thanks for your help and sorry for the inadvertence.
Unfortunately, works on CorelDraw v.12.
I'll check your code on Monday and write if it works.
Thanks again and best regards.
~GrzJanik

[shelbym]

You do not need to test, it will not work in CorelDRAW 12. CorelDRAW 12 does not support CQL.

-Shelby