#11




Hi.
Yep, This is an old one, but a fun one. Here's a quick add to the script above. I don't have much time left tonight so I figured I'd at least give you something to play with. I didn't do the exact math on it yet either. Later I'll redo the entire thing. 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 = getSelectionShapes(True).Shapes(1) 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) 'fillwith whatever Set lilCircle = getSelectionShapes.Shapes(1) lilCircle.SetPosition x, y 'lilCircle.GetSize w1, h1 '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 Private Function getSelectionShapes(Optional bIsContainer As Boolean) As ShapeRange 'just get the two shapes Dim Shift As Long Dim bClick As Boolean Dim s As Shape Dim x#, y#, dTol# dTol = 0.1 ' select shape tolerance ActiveDocument.ClearSelection Set getSelectionShapes = CreateShapeRange If bIsContainer Then MsgBox "Select container" Else MsgBox "Select shape that will go inside the container" End If retrySelectPath: While Not bClick bClick = False bClick = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorEyeDrop) If Not bClick Then Set s = ActivePage.SelectShapesAtPoint(x, y, True, dTol) End If If s.Shapes.count < 1 Then Dim mRetry As Integer mRetry = MsgBox("No shape selected. Try again?", vbOKCancel, "GDG") If mRetry = 1 Then GoTo retrySelectPath: Else 'Set getSelectionShapes = Nothing Exit Function End If End If getSelectionShapes.Add s.Shapes(1) If getSelectionShapes.Shapes.count = 1 Then GoTo exitLoop: Wend exitLoop: End Function 
#12




Quote:
http://macromonster.com/index.php?mo...r&id_desc=139& 
#13




wow thank you very much again. a great code.
I suggest a couple of implementations that would be cool. 1  1  the scale of the circles or the shape could be random. ie circles of different sizes by filling out the shape completely (perhaps from a scale of 100200)and the circles fill the shape perfectly 2  to fill the shape with different mixed forms. bone, you can select 5 different shapes, put them in an array, and be taking one shape or another at random to fill out the shape completely would be really cool? Greetings and congratulations again for your code 
#14




It's possible with ecut, for nesting.
http://macromonster.com/index.php?mod=descr&id_desc=109 Create random sizes in advance then use it to nest inside another shape, with various "fixed" angles you can decide: 
Tags 
artistic, circles, media 
Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)  
Thread Tools  Search this Thread 
Display Modes  


Similar Threads  
Thread  Thread Starter  Forum  Replies  Last Post 
Replace shape with another shape  dungbtl  CorelDRAW/Corel DESIGNER VBA  23  25032018 09:28 
Changing selection when twoshape group loses one shape  Joe  CorelDRAW/Corel DESIGNER VBA  1  19022009 03:50 
Curious 'With Shape.Fill.UniformColor' Bug  RobC  CorelDRAW/Corel DESIGNER VBA  2  18112008 19:17 
Fountain Fill to follow the shape of an object  Alex  FAQ  3  10052007 01:33 
Circles to Circles  Hernán  New product ideas  3  15032004 09:41 