View Single Post
  #1  
Old 23-08-2007, 16:54
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default 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

Last edited by wOxxOm; 05-09-2007 at 14:16.
Reply With Quote