Thread: Fill a shape with Circles View Single Post
#3
07-11-2009, 21:04
 runflacruiser Senior Member Join Date: Jun 2009 Location: Pigeon Forge, TN USA Posts: 811

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(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)

'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
'
'    Next i

For i = 1 To (amountStacked - 1)
Set newCircle = lilCircle.Duplicate
lilCircle.Move 0, dia + space
Next i

Dim rowSh As Shape
Set rowSh = circlesSR.Combine

Dim q As Integer
q = space
For i = 1 To (amountRows)
rowSh.Move intSpotX + q, intSpotY + (amountStacked * (dia + space)) - dia - space
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