View Single Post
  #3  
Old 07-11-2009, 21:04
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

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