OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   CorelDRAW/Corel DESIGNER VBA (http://forum.oberonplace.com/forumdisplay.php?f=16)
-   -   Create fountain fill helper macro (http://forum.oberonplace.com/showthread.php?t=3950)

wOxxOm 23-08-2007 17:54

Create fountain fill helper macro
 
This simple macro helps creating (complex) gradients
For example, to imitate some part of bitmap using gradient fill.
Usage:
1. create a few rectangles
2. switch to EyeDropper (change its mode to ColorSampler)
3. click source bitmap pixel and shift-click the 1st rectangle.
Repeat (3) as many times as needed with another rectangles.
4. Now select all these colored rectangles and run the macro, then click a shape that will be gradient-filled with the colors selected.

Space between source swatches is preserved in the fill.
Fill angle is the angle of a line connecting centers of the first and last source swatches.

Code:

Sub CreateFountain()
  Const pi# = 3.14159265358979
  Dim sh As Shape, swatches As ShapeRange, sr As ShapeRange
  Dim Ccnt&, X#, Y#, cX#, cY#, shift&, pos!, atPos&, prev&, prevSpan#, i&, span#
  On Error Resume Next
  'get selected source swatches
  Set sr = ActiveSelection.shapes.FindShapes
  Ccnt = sr.Count
  If Ccnt < 2 Then Beep: Exit Sub
  If Ccnt > 100 Then MsgBox "Max colors=100", , "Create Fountain fill": Exit Sub
  'ask user to select target shape
  If ActiveDocument.GetUserClick(X, Y, shift, -1, True, 309) Then Exit Sub
  With ActivePage.SelectShapesAtPoint(X, Y, True).shapes
      If .Count = 0 Then Beep: Exit Sub
      Set sh = .Item(.Count)
  End With
 
  'sort by distance:  (1) find center
  ActiveDocument.SaveSettings
  ActiveDocument.ReferencePoint = cdrCenter
  cX = sr.PositionX:  cY = sr.PositionY: span = 0#
  'sort by distance:  (2) find the most remote object rel. to [cx,cy]
  For i = 1 To Ccnt
      X = sr(i).PositionX: Y = sr(i).PositionY
      pos = Sqr((X - cX) ^ 2 + (Y - cY) ^ 2)
      If pos >= span Then prev = atPos: atPos = i: span = pos _
        Else If pos > prevSpan Then prev = i: prevSpan = pos
  Next
  If prev Then _
      If sr(prev).PositionX < cX And sr(atPos).PositionX > cX Then atPos = prev _
        Else If sr(prev).PositionY > cY And sr(atPos).PositionY < cY Then atPos = prev
  'sort by distance:  (3) sort relative to found item
  Set swatches = New ShapeRange
  swatches.Add sr(atPos): sr.Remove atPos
  X = swatches(1).PositionX: Y = swatches(1).PositionY
  Do While sr.Count
      span = 3E+38
      For i = 1 To sr.Count
        pos = Sqr((sr(i).PositionX - X) ^ 2 + (sr(i).PositionY - Y) ^ 2)
        If pos <= span Then atPos = i: span = pos
      Next
      swatches.Add sr(atPos): sr.Remove atPos
  Loop
  Set swatches = swatches.ReverseRange
 
  ActiveDocument.BeginCommandGroup "Create fountain fill"
 
  pos = 100 / (Ccnt - 1)
  X = swatches(1).PositionX: Y = swatches(1).PositionY
  span = Sqr((swatches(Ccnt).PositionX - X) ^ 2 + (swatches(Ccnt).PositionY - Y) ^ 2)
  With sh.Fill.ApplyFountainFill(swatches(1).Fill.UniformColor, swatches(Ccnt).Fill.UniformColor)
      If swatches(Ccnt).PositionX = X Then .SetAngle Sgn(swatches(Ccnt).PositionY - swatches(1).PositionY) * 90 _
        Else cX = 180# / pi * Atn((swatches(Ccnt).PositionY - Y) / (swatches(Ccnt).PositionX - X)): _
              .SetAngle Switch(cX = 0, 0, cX > 0, cX, cX < 0, 180 + cX)
      For i = 2 To Ccnt - 1
        If span > 0 Then atPos = Sqr((swatches(i).PositionX - X) ^ 2 + (swatches(i).PositionY - Y) ^ 2) / span * 100 _
            Else atPos = pos * (i - 1)
        .colors.Add swatches(i).Fill.UniformColor, atPos
      Next
      .SetEdgePad 0
  End With
  ActiveDocument.RestoreSettings
  ActiveDocument.EndCommandGroup
  swatches.CreateSelection
End Sub


ddonnahoe 24-08-2007 08:12

Isn't there a way to store the eyedropper click pixel color via VBA in a collection and then have the user hit a certain key on the keyboard when finished choosing colors? Then the macro could run and pull the color info from the collection.

wOxxOm 24-08-2007 09:25

I understand your words as a wonderful idea for a macro FFColorCollector! yet I like current implementation (try it, btw!) - it's more visual and of course faster than creating FF manually using InteractiveFillTool or (save our souls!) FountainFillDialog

Jeff Harrison 04-09-2007 02:17

1 Attachment(s)
Hi Os,

I love your new macro. MUUCCCHHH faster than other methods so far. :-) Is there a way though for it to "auto sense" the orientation of the FF based on the filled boxes and apply that way? Here's an example of what I mean:

BTW this is that photoshop fill that's used a zillion times...:-)

Jeff Harrison 04-09-2007 18:58

1 Attachment(s)
hi Os,

I hope you're a girl, cuz I'm gonna kiss you. ;-)

One more thing... should the selection order of the squares make a difference before running macro? It does now.

Also - on my rig I've had to run this whole thing as Sub, not Private Sub BTW.

Jeff Harrison 04-09-2007 20:31

1 Attachment(s)
hi Os,

In one direction it works good - but it depends on the stacking order in object manager how the macro works. Open my CDR here and see.

Jeff Harrison 04-09-2007 22:14

Hi Os,

Hmmm.. still backwards sometimes, depending on the order the colored boxes are selected (right before running macro). It's OK, don't lose sleep over it. All the person has to do is select the boxes in reverse order. I was just suggesting this so that people don't bug you later wondering why sometimes it's one way and other times another.

Good Job! I like this one a lot!

Jeff Harrison 04-09-2007 22:55

1 Attachment(s)
Os,

I don't know what to say... you are a true genius to me!

You work so hard, and I want you to know how much people appreciate you.

The macro now works when going from top down or bottom up with aligned boxes... but now checked the attached. Don't have a nervous breakdown, we need you!!! :-)

Jeff Harrison 05-09-2007 00:32

1 Attachment(s)
A small gift for Os to keep him inspired.

wOxxOm 05-09-2007 01:05

Updated: IT SEEMS TO WORK ok whatever order of selecting shapes

btw, a tip to create color swatches mimicking part of bitmap - duplicate the bitmap, crop it to the area in question, trace it (X3's PowerTrace) setting Details level to have as many objects as needed, trace and select the shapes, align to center if needed, run the macro

Jeff Harrison 05-09-2007 01:51

1 Attachment(s)
hi Os,

That's a great tip! Very clever.

BTW.. check this file... some ordering issues still.

wOxxOm 05-09-2007 15:18

I've dug some math...seems to be ok now.
btw, I may risk stealing your thunder but your mojo should deal with it :-D - how about creating a tutorial in pictures on your blog? It would be very cool and popular imho and I'll link my blog/site macro's entry to it

Jeff Harrison 06-09-2007 00:40

2 Attachment(s)
Hi Os,

I think I'd do a movie instead, then people can see it all and listen to my handsome voice too. :-p

see the attached, I could include it too.

To make it EZ, it should be in a GMS - I have the code in one on my rig, but if you want to provide an "official one" that's cool.

Also, this is the only mojo I know about. :-)

Jeff Harrison 06-09-2007 04:25

1 Attachment(s)
a little pic for Os

ddonnahoe 06-09-2007 08:14

Good one Jeff. Did you use the macro to set up those gradients? Nice lighting effects at the top.

Sean

wOxxOm 06-09-2007 10:08

the macro is included in gms: http://woxxom-macros.blogspot.com/20...untain_28.html

Jeff Harrison 06-09-2007 22:00

Yes, gradient was re-built from one of PS's.

Many of Draw's FF's are beyond cheezy, so this is a handy macro...

This image is 100% Draw/PP

JD

Quote:

Originally Posted by ddonnahoe (Post 10603)
Good one Jeff. Did you use the macro to set up those gradients? Nice lighting effects at the top.

Sean


Jeff Harrison 06-09-2007 22:02

OK, thanks OS...

U R a machine. I'd like to review several of your macros, with your blessing. perhaps in a series of videos... Then people can see what they do.

Jeff

Quote:

Originally Posted by wOxxOm (Post 10605)


wOxxOm 07-09-2007 08:28

one is enough, isn't it?
edit: can't believe you're serious. If so, then I kiss you or no, bliss, or no, bless you! :-D

Jeff Harrison 07-09-2007 13:32

hi Os,

Ahh, so love is in the air over these macros. ;-)

It's actually faster for me to make the vids than written tuts.

OK, when I have time I'll make the vids and have links to your macros.

I know you have several sites where you have the macros, are you going to have one single place eventually? Or, provide the most "permanent" domain to me for them.

wOxxOm 07-09-2007 13:44

I don't have a permanent domain nor I see one in the *near* future.
recentfiles.sbn.bz and recent.tekcities.com allow external linking of stuff but both of them seem to be less reliable - 5 downs for 1 yr as opposed to 1 or 2 at recentfiles.netfirms.com which does not allow direct external linking of stuff like images and zip/exe.

Jeff Harrison 07-09-2007 15:40

Hi Os,

Hmm. I think I can help, I sent you a private message.


All times are GMT -5. The time now is 05:55.

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