Create fountain fill helper macro

[wOxxOm]

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.

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]

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]

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

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...:-)

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.

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.

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!

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!!! :-)

A small gift for Os to keep him inspired.

[wOxxOm]

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