OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 06-11-2009, 09:16
biok
Guest
 
Posts: n/a
Default 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.
Reply With Quote
  #2  
Old 06-11-2009, 23:30
Jeff Harrison
Guest
 
Posts: n/a
Default

This does that, and lots more..
Reply With Quote
  #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
  #4  
Old 09-11-2009, 10:37
biok
Guest
 
Posts: n/a
Default

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; 09-11-2009 at 11:23.
Reply With Quote
  #5  
Old 09-11-2009, 22:37
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default 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
Reply With Quote
  #6  
Old 10-11-2009, 14:09
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

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

-John
Reply With Quote
  #7  
Old 10-11-2009, 14:55
ddonnahoe's Avatar
ddonnahoe ddonnahoe is offline
Senior Member
 
Join Date: Jan 2004
Location: Louisville, KY
Posts: 552
Send a message via ICQ to ddonnahoe Send a message via AIM to ddonnahoe Send a message via MSN to ddonnahoe Send a message via Yahoo to ddonnahoe
Default

I'd love to see it.
__________________
Sean
Waiting for a ride in the T.A.R.D.I.S.
Reply With Quote
  #8  
Old 10-11-2009, 15:13
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

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
Reply With Quote
  #9  
Old 13-11-2009, 12:00
biok
Guest
 
Posts: n/a
Default 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; 13-11-2009 at 12:53.
Reply With Quote
  #10  
Old 04-03-2011, 17:08
buga buga is offline
Senior Member
 
Join Date: Jan 2011
Posts: 114
Default

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

Tags
artistic, circles, media


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Replace shape with another shape dungbtl CorelDRAW/Corel DESIGNER VBA 24 28-12-2019 05:56
Changing selection when two-shape group loses one shape Joe CorelDRAW/Corel DESIGNER VBA 1 19-02-2009 03:50
Curious 'With Shape.Fill.UniformColor' Bug RobC CorelDRAW/Corel DESIGNER VBA 2 18-11-2008 19:17
Fountain Fill to follow the shape of an object Alex FAQ 3 10-05-2007 01:33
Circles to Circles Hernán New product ideas 3 15-03-2004 09:41


All times are GMT -5. The time now is 19:23.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com