OberonPlace.com Forums

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)
-   Macros/Add-ons (http://forum.oberonplace.com/forumdisplay.php?f=21)
-   -   shaperange.add (http://forum.oberonplace.com/showthread.php?t=7723)

HeauxmBru 27-06-2011 01:50

I am having trouble with the shaperange.add method. I am using it in a For statement with a shape.duplicate(...) method. For some reason I only have 1 shape in the range through the procedure. I've seen this same code in other procedures and it works fine. Just not in mine. I've tried several things but nothing works. I'm not sure what I'm missing.

Here is my code:

Sub CreateDuplicates()

    Const conX As Double = 0.25540157480315 '  x position of NSI Box
    Const conY As Double = 0.1685          '  y position of NSI Box
    Const conW As Double = 13.7275          '  w width of NSI Box
    Const conH As Double = 10.5449015748032 '  h height of NSI Box
    Const Margin As Double = 0.025            '  Page margin in inches
    Dim s1 As Shape, s2 As Shape
    Dim sr As New ShapeRange
    Dim i As Integer
    Dim x#, y#, w#, h#
    Dim x1#, y1#, w1#, h1#
    Dim xGutter As Double, yGutter As Double
    Dim RowNum As Long, ColNum As Long
    Dim sx As Double, sy As Double          '  new coords for first shape
    Dim d As Document
    Set d = ActiveDocument
    d.BeginCommandGroup "Create Duplicates"
    On Error GoTo ErrHandler
    Set s1 = ActiveSelection            '  target shape
    s1.GetBoundingBox x, y, w, h        '  target coords +
    w1 = w
    h1 = h
    RowNum = conW / (w + 1 + Margin)
    xGutter = (conW - (w * RowNum)) / (RowNum + 1)
    sx = xGutter + conX
    ColNum = conH / (h + 1 + Margin)
    yGutter = (conH - (h * ColNum)) / (ColNum + 1)
    sy = yGutter + conY

    d.DrawingOriginY = d.ActivePage.SizeHeight / 2

    s1.SetPosition sx, -sy
    sr.Add s1
    For i = 1 To RowNum - 1
        sr.Add s1.Duplicate(w + xGutter, 0)
'        Set s2 = s1.Duplicate
'        s2.Move w + xGutter, 0
'        s2.Fill.UniformColor.CMYKAssign 0, 100, 0, 0
        s1.Fill.UniformColor.CMYKAssign 0, 100, 0, 0
        w = w + w1 + xGutter
'        MsgBox sr.Count & " shapes", vbOKOnly
    Next i
    d.DrawingOriginY = -d.ActivePage.SizeHeight / 2
    Exit Sub
    MsgBox "Error occured: " & Err.Description
    Resume ExitSub
End Sub

I'd appreciate any suggestions.

runflacruiser 27-06-2011 13:24

Duplicate can be tricky.
The trick is to slowly debug through code and grab your shape as needed.

Try this mod of your loop.


    For i = 1 To RowNum - 1
        s1.Duplicate 1, 1
        Set s2 = ActiveShape.Next
'      sr.Add s1.Duplicate(w + xGutter, 0)
'      Set s2 = s1.Duplicate
'      s2.Move w + xGutter, 0
        s2.Fill.UniformColor.CMYKAssign 0, 100, 0, 0
        sr.Add s2
        s1.Fill.UniformColor.CMYKAssign 100, , 0, 0
        w = w + w1 + xGutter
'        MsgBox sr.Count & " shapes", vbOKOnly
    Next i


HeauxmBru 28-06-2011 12:49

I tried your suggestion to use .next . I found it interesting and it actually allowed me to have 2 shapes in the shaperange instead of 1. But, sadly, it wasn't enough.

Two problems: 1. .next was picking up a text shape that was on the page instead of the duplicated shape. It actually goes down the list of shapes rather than up (which is where the dups are) so that it picks the next shape behind the shape I am duplicating.
2. It only picks up 1 shape during the loop rather than 1 for every iteration. So I only get 2 shapes in my range rather than all the dups. I was having that same problem before with .add except that I only got 1 shape in the range.

I think somehow I need to be able to reference each dup after the fact, rather than sr.add s1.duplicate. I just don't know how to do that.

The duplication loop is working like I wanted. It makes duplicates of the selected shape and fits as many as can fit in the given space, based on the size of the selected shape. The next step is to do the same thing vertically, but I need all the shapes selected and grouped so I can duplicate downward. That's where it fails as I only have the original (or maybe the last dup) selected.

I'll keep trying till something breaks.:dontknow:

Thanks John

runflacruiser 28-06-2011 12:54

I was able to grab both shapes here. Using X5.
I'll take another look also.

shark 29-06-2011 01:26

1 Attachment(s)
I did not find any mistakes. I've selected one blue rectangle, run this macro and got 7 red rectangles. sr.Count = 8
I do not know why you need this strange copying...

HeauxmBru 29-06-2011 13:49

That's what I expected to get. This makes me wonder if something on my machine wacky.

HeauxmBru 29-06-2011 13:54

That's what I get using .move not .duplicate. It should have equal spacing throughout. I'm trying to fit whatever size shape multiple times equally spaced in a specific area on the page (11X17), both horizontally and vertically. Everything was good till SR.ADD decided not to add any of the dups.

HeauxmBru 29-06-2011 17:59

I got an idea. If it works, I'll post the result.

HeauxmBru 29-06-2011 23:02

Hey guys,

I finally got it to work.

Here's what I did.


 lName = ActivePage.ActiveLayer.Name
    Set lr = ActivePage.CreateLayer("MyLayer")
    s1.MoveToLayer lr

    s1.SetPosition sx, -sy
    sr.Add s1
    For i = 1 To RowNum - 1
        s1.Duplicate w + xGutter, 0
        w = w + w1 + xGutter
    Next i

    Set sr = ActivePage.ActiveLayer.Shapes.All
    sr.GetBoundingBox x, y, w, h
    w1 = w
    h1 = h
    For i = 1 To ColNum - 1
        s1.Duplicate 0, -h + -yGutter
        h = h + h1 + yGutter
    Next i

    Set sr = ActivePage.ActiveLayer.Shapes.All
    Set lr = ActivePage.Layers.Find(lName)

I still don't understand why sr.add didn't work. Seems like it should've.

shark 30-06-2011 01:47

You can use my macros for shape's placement. May be this is that you need.

All times are GMT -5. The time now is 17:14.

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