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
MyAccount
