OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

 
 
Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #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
 


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Fountain Fill to follow the shape of an object Alex FAQ 3 10-05-2007 00:33
Macro for create boundary option nikhiscd Macros/Add-ons 14 31-10-2006 23:38
Removing Fountain Fills Macro problem knowbodynow CorelDRAW/Corel DESIGNER VBA 3 09-07-2006 11:10
Fountain Fill changes when object is rotated Alex FAQ 1 03-05-2005 22:35
object lost it's linear fountain fill property after metalickaah CorelDRAW/Corel DESIGNER VBA 5 02-01-2005 22:36


All times are GMT -5. The time now is 07:20.


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