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 16:54

Create fountain fill helper macro
This simple macro helps creating (complex) gradients
For example, to imitate some part of bitmap using gradient fill.
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.


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.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
  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
      swatches.Add sr(atPos): sr.Remove atPos
  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
      .SetEdgePad 0
  End With
End Sub

ddonnahoe 24-08-2007 07: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 08: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 01: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 17: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 19: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 21: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 21:55

1 Attachment(s)

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 04-09-2007 23:32

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

wOxxOm 05-09-2007 00: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

All times are GMT -5. The time now is 06:53.

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