OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   Macros/Add-ons (http://forum.oberonplace.com/forumdisplay.php?f=21)
-   -   Fountain to bitmap in powerclip (http://forum.oberonplace.com/showthread.php?t=7713)

grzjanik 15-06-2011 03:57

Fountain to bitmap in powerclip
 
Hello everyone.

I need something like this:

1. Duplicate the curve in the same place.
http://grzjanik.ovh.org/oberon/s1.jpg

2. Put the original to Powerclip and enlarge the curve about 1 mm.
http://grzjanik.ovh.org/oberon/s2.jpg

3. Fountain Set by steps to 999.
http://grzjanik.ovh.org/oberon/s3.jpg

4. Contents Powerclip converts the bitmap (CMYK, 300 dpi).
http://grzjanik.ovh.org/oberon/s4.jpg

5. Exit from Powerclip.
http://grzjanik.ovh.org/oberon/s5.jpg

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 07-07-2011 03:12

Half of success :)
 
Hello members of Oberon.

I managed to do something like this:

Quote:

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 07-07-2011 03:56

Add Fountain 999 :)
 
Now the code looks like this:

Quote:

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 25-08-2011 02:56

Unfortunately
 
Unfortunately, it works but not always correctly. :(

grzjanik 25-08-2011 03:09

Help
 
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 29-08-2011 12:14

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 29-08-2011 12:33

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 29-08-2011 23:25

Gradient to Powerclip
 
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:
Code:

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 02-09-2011 03:58

Corel 12
 
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 03-09-2011 23:06

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

-Shelby


All times are GMT -5. The time now is 21:31.

Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com