OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 23-08-2007, 17: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 15:16.
Reply With Quote
  #2  
Old 24-08-2007, 08:12
ddonnahoe's Avatar
ddonnahoe ddonnahoe is offline
Senior Member
 
Join Date: Jan 2004
Location: Louisville, KY
Posts: 552
Send a message via ICQ to ddonnahoe Send a message via AIM to ddonnahoe Send a message via MSN to ddonnahoe Send a message via Yahoo to ddonnahoe
Default

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.
__________________
Sean
Waiting for a ride in the T.A.R.D.I.S.
Reply With Quote
  #3  
Old 24-08-2007, 09:25
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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

Last edited by wOxxOm; 04-09-2007 at 09:52.
Reply With Quote
  #4  
Old 04-09-2007, 02:17
Jeff Harrison
Guest
 
Posts: n/a
Default

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...:-)
Attached Images
 
Reply With Quote
  #5  
Old 04-09-2007, 18:58
Jeff Harrison
Guest
 
Posts: n/a
Default

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.
Attached Images
 
Reply With Quote
  #6  
Old 04-09-2007, 20:31
Jeff Harrison
Guest
 
Posts: n/a
Default

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.
Attached Files
File Type: cdr os.cdr (15.6 KB, 550 views)
Reply With Quote
  #7  
Old 04-09-2007, 22:14
Jeff Harrison
Guest
 
Posts: n/a
Default

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!
Reply With Quote
  #8  
Old 04-09-2007, 22:55
Jeff Harrison
Guest
 
Posts: n/a
Default

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!!! :-)
Attached Files
File Type: cdr os123.cdr (16.0 KB, 534 views)
Reply With Quote
  #9  
Old 05-09-2007, 00:32
Jeff Harrison
Guest
 
Posts: n/a
Default

A small gift for Os to keep him inspired.
Attached Files
File Type: cdr os.cdr (52.9 KB, 535 views)
Reply With Quote
  #10  
Old 05-09-2007, 01:05
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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
Reply With Quote
Reply


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 01:33
Macro for create boundary option nikhiscd Macros/Add-ons 14 01-11-2006 00:38
Removing Fountain Fills Macro problem knowbodynow CorelDRAW/Corel DESIGNER VBA 3 09-07-2006 12:10
Fountain Fill changes when object is rotated Alex FAQ 1 03-05-2005 23:35
object lost it's linear fountain fill property after metalickaah CorelDRAW/Corel DESIGNER VBA 5 02-01-2005 23:36


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


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