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.

This does that, and lots more..

[runflacruiser]

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.

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

-John

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.

[runflacruiser]

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

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

[runflacruiser]

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

-John

[ddonnahoe]

I'd love to see it.

[runflacruiser]

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

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

to avoid circles touching the shape outline. You can use this....

 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

[buga]

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