#1




Fill a shape with Circles
Hi, does anyone know how to fill a shape with circles of the same size and sprayed with the same separation between them all along the shape. Something like the Artistic Media tool with the outlines, but the Artistic Media is not supported in VBA.

#2




This does that, and lots more..

#3




Here's my attempt at this...
It's one way to fill any shape with any size circle. set your circle size in the macro. Code:
Sub fillWithCircles() Dim container As Shape Dim lilCircle As Shape Dim x#, y#, h#, w# Dim x1#, y1# Dim dia#, space#, marg# Dim amountStacked As Long Dim amountRows As Long Dim totalCircles As Long Dim i As Integer Dim circles As Shape Dim circlesSR As New ShapeRange Dim ContainerSr As New ShapeRange Dim newCircle As Shape Dim finalCirclesSr As ShapeRange Dim finalCircleS As Shape Dim sTemp As Shape Dim w1#, h1# ActiveDocument.BeginCommandGroup "fill with circles" dia = 0.3 'set your circle diameter here space = 0.1 'spacing between circles marg = 0.1 ' margin away from edge, doesn't really work good.... 'get the active selection and add it to a shaperange and get it's bounding box Set container = ActiveSelection ContainerSr.Add container ContainerSr(1).GetBoundingBox x, y, w, h 'create the first circle to which you will duplicate later ' add it to it's own shaperange for circles Set lilCircle = ActiveLayer.CreateEllipse2(x + (dia / 2) + marg, y + (dia / 2) + marg, dia / 2) circlesSR.Add lilCircle 'fit in height amountStacked = (h  (marg * 2)) / (dia + space) amountRows = (w  (marg * 2)) / (dia + space) totalCircles = amountStacked * amountRows Dim intSpotX As Double, intSpotY As Double intSpotX = dia + space intSpotY = (dia  (amountStacked * (dia + space))) + space 'slower way, circle by circle ' For i = 1 To (totalCircles  1) Step 1 ' Set newCircle = lilCircle.Duplicate ' ' If ((i Mod amountStacked) = 0) Then ' lilCircle.Move intSpotX, intSpotY ' Else ' lilCircle.Move 0, dia + space ' End If ' ' circlesSR.Add newCircle ' Next i For i = 1 To (amountStacked  1) Set newCircle = lilCircle.Duplicate lilCircle.Move 0, dia + space circlesSR.Add newCircle Next i Dim rowSh As Shape Set rowSh = circlesSR.Combine Dim q As Integer Dim rowShAdd As Shape q = space For i = 1 To (amountRows) Set rowShAdd = rowSh.Duplicate rowSh.Move intSpotX + q, intSpotY + (amountStacked * (dia + space))  dia  space circlesSR.Add rowShAdd q = q + q If i = amountRows Then rowSh.Delete End If Next i Set circles = circlesSR.All.Combine circles.Intersect ContainerSr(1), False, True Set finalCircleS = ActiveSelection.Shapes.All.Combine Set finalCirclesSr = finalCircleS.BreakApartEx 'find in any circles are not round after trimming. For Each sTemp In finalCirclesSr h1 = sTemp.SizeHeight w1 = sTemp.SizeWidth If w1 <> dia Or h1 <> dia Then sTemp.Rotate 45 h1 = sTemp.SizeHeight w1 = sTemp.SizeWidth If w1 <> dia Or h1 <> dia Then sTemp.Delete End If End If Next sTemp ActiveDocument.EndCommandGroup End Sub 
#4




Thanks John that is exactly what I was looking for. I'm testing it, and I'll try to make some improvements to the "margin away from edge" part. If I can achieve this I will let you know.
Last edited by biok; 09112009 at 10:23. 
#5




fill shape with star or circles
fill shape with circle, stars or whatever you want
had a little more time to fix it up.... This one should now work with any shape. I put for star and circle... If you wanna tackle the distance measurement for the correct spacing have at it. I'm out of brain power for the night. Just look at where it says "better method" use a the formula to find the c side of right triangle and calculate your distance for the staggered shape. This is all it needs for perfect symmetry. I'll work on it later if I get more time. John Code:
Sub fillWithCircles() Dim container As Shape, circles As Shape Dim lilCircle As Shape, lilCircle2 As Shape, rowShAdd As Shape, tempSh1 As Shape Dim x#, y#, h#, w#, w1#, h1# Dim x1#, y1# Dim dia#, space#, marg# Dim amountStacked As Long Dim amountRows As Long, totalCircles As Long Dim i As Integer Dim circlesSR As New ShapeRange Dim ContainerSr As New ShapeRange Dim finalCirclesSr2 As New ShapeRange Dim newCircle As Shape, newCircle2 As Shape Dim finalCircleS As Shape, sTemp As Shape, finalCircleS2 As Shape, rowSh As Shape Dim crspt As CrossPoints Dim tempSr1 As ShapeRange, finalCirclesSr As ShapeRange ActiveDocument.BeginCommandGroup "fill with circles" dia = 0.2 'set your circle (or any shape) diameter here space = 0.1 'spacing between circles marg = 0.01 ' just a starting point 'get the active selection and add it to a shaperange and get it's bounding box Set container = ActiveSelection container.ConvertToCurves 'convert it to curves so we can detect crosspoints later. ContainerSr.Add container ContainerSr(1).GetBoundingBox x, y, w, h 'create the first and 2nd shape (staggered shapes) 'add it to it's own shaperange for circles 'create whatever shape you want here  or 2 different shapes!!! 'fill with circles 'Set lilCircle = ActiveLayer.CreateEllipse2(x + (dia / 2) + marg, y + (dia / 2) + marg, dia / 2) 'Set lilCircle2 = ActiveLayer.CreateEllipse2(x + marg + ((dia / 2) * 3), y + (marg / 2), dia / 2) 'better method  need to figure formula for right triangle  '''Set lilCircle2 = lilCircle.Duplicate() 'better but need the formula for x and y distance. You'll also have to add the x value in the spacing below. 'fill with stars Set lilCircle = ActiveLayer.CreatePolygon2(x + (dia / 2) + marg, y + (dia / 2) + marg, dia / 2, 5, , , True) Set lilCircle2 = ActiveLayer.CreatePolygon2(x + marg + ((dia / 2) * 3), y + (marg / 2), dia / 2, 5, , , True) Set lilCircle = lilCircle.Weld(lilCircle, False, False) Set lilCircle2 = lilCircle2.Weld(lilCircle2, False, False) 'how many fit in height amountStacked = (h  (marg * 2)) / (dia + space) 'create first row vertically For i = 1 To (amountStacked  1) Set newCircle = lilCircle.Duplicate lilCircle.Move 0, dia + space newCircle.AddToSelection lilCircle.AddToSelection Next i 'create 2nd (staggered) row For i = 1 To (amountStacked) Set newCircle2 = lilCircle2.Duplicate lilCircle2.Move 0, dia + space newCircle2.AddToSelection lilCircle2.AddToSelection Next i 'group all the shapes we created and set them assign to a shape ActiveSelection.Group Set circles = ActiveSelection circles.AlignToShape cdrAlignVCenter, ContainerSr(1) circles.GetSize w1, h1 amountRows = ((w  (marg * 2)) / (w1 + space)) + 1 Set rowSh = circles.Combine 'now create rows across horizontally... For i = 1 To amountRows + 1 Set rowShAdd = rowSh.Duplicate rowSh.Move w1, 0 circlesSR.Add rowShAdd Next i circlesSR.Add rowSh circlesSR.CreateSelection Set tempSr1 = ActiveSelection.UngroupAllEx tempSr1.CreateSelection 'align the group of shapes to center of container horizontally Set tempSh1 = ActiveSelection.Combine tempSh1.AlignToShape cdrAlignHCenter, ContainerSr(1) Set finalCircleS = ActiveSelection.Shapes.All.Combine Set finalCirclesSr = finalCircleS.BreakApartEx 'find intersecting shapes and delete For Each sTemp In finalCirclesSr Set crspt = sTemp.Curve.SubPaths(1).GetIntersections(ContainerSr(1).Curve.SubPaths(1)) If crspt.count > 0 Then sTemp.Delete Else sTemp.AddToSelection End If Next sTemp 'remove the rest that lay outside of container Set finalCircleS2 = ActiveSelection.Shapes.All.Combine finalCircleS2.Intersect ContainerSr(1), False, True ActiveDocument.EndCommandGroup End Sub 
#6




I got the finished one with perfect staggered spacing fixed.
If anyone wants it let me know John 
#7




I'd love to see it.
__________________
Sean Waiting for a ride in the T.A.R.D.I.S. 
#8




no prob...
this one should make the spacing even. Great for american flag style spaced stars! I didnt use the duplicate method for the stars because x4 has a bug when weld is set to false, false on duplicated shapes so it seems....you'll see. We could perfect the margin by putting an inline on the container shape and deleting later but this would take more time too.. John Code:
Option Explicit Sub fillWithCircles() Dim container As Shape, circles As Shape Dim lilCircle As Shape, lilCircle2 As Shape, rowShAdd As Shape, tempSh1 As Shape Dim x#, y#, h#, w#, w1#, h1# Dim x1#, y1# Dim dia#, space#, marg# Dim amountStacked As Long Dim amountRows As Long, totalCircles As Long Dim i As Integer Dim circlesSR As New ShapeRange Dim ContainerSr As New ShapeRange Dim finalCirclesSr2 As New ShapeRange Dim newCircle As Shape, newCircle2 As Shape Dim finalCircleS As Shape, sTemp As Shape, finalCircleS2 As Shape, rowSh As Shape Dim crspt As CrossPoints Dim tempSr1 As ShapeRange, finalCirclesSr As ShapeRange Dim a#, b#, c# ActiveDocument.BeginCommandGroup "fill with circles" dia = 0.2 'set your circle (or any shape) diameter here space = 0.1 'spacing between circles marg = 0.01 ' just a starting point 'get the active selection and add it to a shaperange and get it's bounding box Set container = ActiveSelection container.ConvertToCurves 'convert it to curves so we can detect crosspoints later. ContainerSr.Add container ContainerSr(1).GetBoundingBox x, y, w, h 'create the first and 2nd shape (staggered shapes) 'add it to it's own shaperange for circles 'create whatever shape you want here  or 2 different shapes!!! a = (dia / 2) + (space / 2) c = dia + space b = Sqr(c ^ 2  a ^ 2) ' side we need to calculate 'fill with circles Set lilCircle = ActiveLayer.CreateEllipse2(x + (dia / 2) + marg, y + (dia / 2) + marg, dia / 2) Set lilCircle2 = lilCircle.Duplicate(b, a) 'fill with stars 'Set lilCircle = ActiveLayer.CreatePolygon2(x + (dia / 2) + marg, y + (dia / 2) + marg, dia / 2, 5, , , True) 'Set lilCircle2 = ActiveLayer.CreatePolygon2(x + (dia / 2) + marg + b, y + (marg / 2), dia / 2, 5, , , True) 'Set lilCircle = lilCircle.Weld(lilCircle, False, False) 'Set lilCircle2 = lilCircle2.Weld(lilCircle2, False, False) 'how many fit in height amountStacked = (h  (marg * 2)) / (dia + space) 'create first row vertically For i = 1 To (amountStacked  1) Set newCircle = lilCircle.Duplicate lilCircle.Move 0, dia + space newCircle.AddToSelection lilCircle.AddToSelection Next i 'create 2nd (staggered) row For i = 1 To (amountStacked) Set newCircle2 = lilCircle2.Duplicate lilCircle2.Move 0, dia + space newCircle2.AddToSelection lilCircle2.AddToSelection Next i 'group all the shapes we created and set them assign to a shape ActiveSelection.Group Set circles = ActiveSelection circles.AlignToShape cdrAlignVCenter, ContainerSr(1) circles.GetSize w1, h1 amountRows = ((w  (marg * 2)) / (w1 + b)) + 1 Set rowSh = circles.Combine 'now create rows across horizontally... For i = 1 To amountRows + 2 Set rowShAdd = rowSh.Duplicate rowSh.Move b * 2, 0 circlesSR.Add rowShAdd Next i circlesSR.Add rowSh circlesSR.CreateSelection Set tempSr1 = ActiveSelection.UngroupAllEx tempSr1.CreateSelection 'align the group of shapes to center of container horizontally Set tempSh1 = ActiveSelection.Combine tempSh1.AlignToShape cdrAlignHCenter, ContainerSr(1) Set finalCircleS = ActiveSelection.Shapes.All.Combine Set finalCirclesSr = finalCircleS.BreakApartEx 'find intersecting shapes and delete For Each sTemp In finalCirclesSr Set crspt = sTemp.Curve.SubPaths(1).GetIntersections(ContainerSr(1).Curve.SubPaths(1)) If crspt.count > 0 Then sTemp.Delete Else sTemp.AddToSelection End If Next sTemp 'remove the rest that lay outside of container Set finalCircleS2 = ActiveSelection.Shapes.All.Combine finalCircleS2.Intersect ContainerSr(1), False, True ActiveDocument.EndCommandGroup End Sub 
#9




avoid circles touching the outline
to avoid circles touching the shape outline. You can use this....
Code:
Dim polygon As Shape Dim stch# stch = 1  (marg / ContainerSr(1).SizeWidth) Set polygon = ContainerSr(1).Duplicate polygon.Stretch stch, stch, True polygon.OrderToFront 'find intersecting shapes and delete For Each sTemp In finalCirclesSr Set crspt = sTemp.Curve.SubPaths(1).GetIntersections(polygon.Curve.SubPaths(1)) If crspt.Count > 0 Then sTemp.Delete Else sTemp.AddToSelection End If Next sTemp 'remove the rest that lay outside of container Set finalCircleS2 = ActiveSelection.Shapes.All.Combine finalCircleS2.Intersect polygon, False, True polygon.Delete ActiveDocument.EndCommandGroup Last edited by biok; 13112009 at 11:53. 
#10




Wow this code is amazing.
I have a question. As I can use squares or rectangles instead of circles or stars? And using a custom shape? I know that the post is old but would be very grateful if someone could help me thanks in advance Greetings 
Tags 
artistic, circles, media 
Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)  
Thread Tools  Search this Thread 
Display Modes  


Similar Threads  
Thread  Thread Starter  Forum  Replies  Last Post 
Replace shape with another shape  dungbtl  CorelDRAW/Corel DESIGNER VBA  24  28122019 04:56 
Changing selection when twoshape group loses one shape  Joe  CorelDRAW/Corel DESIGNER VBA  1  19022009 02:50 
Curious 'With Shape.Fill.UniformColor' Bug  RobC  CorelDRAW/Corel DESIGNER VBA  2  18112008 18:17 
Fountain Fill to follow the shape of an object  Alex  FAQ  3  10052007 00:33 
Circles to Circles  Hernán  New product ideas  3  15032004 08:41 