OberonPlace.com Forums  

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

Thread Tools Search this Thread Display Modes
Old 04-03-2011, 19:13
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811

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.


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
    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
    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
    Set tempSr1 = ActiveSelection.UngroupAllEx

'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
        End If
    Next sTemp
'remove the rest that lay outside of container
    Set finalCircleS2 = ActiveSelection.Shapes.All.Combine
    finalCircleS2.Intersect ContainerSr(1), False, True
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
    Set getSelectionShapes = CreateShapeRange
    If bIsContainer Then
        MsgBox "Select container"
        MsgBox "Select shape that will go inside the container"
    End If
    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:
                'Set getSelectionShapes = Nothing
                Exit Function
            End If
        End If
        getSelectionShapes.Add s.Shapes(1)
        If getSelectionShapes.Shapes.count = 1 Then GoTo exitLoop:
End Function
Reply With Quote
Old 04-03-2011, 19:28
Jeff Harrison
Posts: n/a

Originally Posted by biok View Post
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.
LEDTool 4 does that and much more:

Reply With Quote
Old 05-03-2011, 05:30
buga buga is offline
Senior Member
Join Date: Jan 2011
Posts: 114

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 100-200)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
Reply With Quote
Old 05-03-2011, 12:00
Jeff Harrison
Posts: n/a

It's possible with ecut, for nesting.

Create random sizes in advance then use it to nest inside another shape, with various "fixed" angles you can decide:
Attached Images
Reply With Quote

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 04:56
Changing selection when two-shape group loses one shape Joe CorelDRAW/Corel DESIGNER VBA 1 19-02-2009 02:50
Curious 'With Shape.Fill.UniformColor' Bug RobC CorelDRAW/Corel DESIGNER VBA 2 18-11-2008 18:17
Fountain Fill to follow the shape of an object Alex FAQ 3 10-05-2007 00:33
Circles to Circles Hernán New product ideas 3 15-03-2004 08:41

All times are GMT -5. The time now is 08:09.

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