Macro placement of objects

Need help placing objects below one another.

Here's how the current macro is placing the objects on page 1.


So for each object on each page, move to page 1, below text 1, repeat and place below text 2, etc...

Sub pagesToLayers()
    Dim s As Shape, sr As ShapeRange
    Dim p As Page, i&, l As Layer
   
    For i = 1 To ActiveDocument.Pages.Count
        ActiveDocument.Pages(i).Activate
        Set sr = ActivePage.Shapes.All
        If sr.Count > 0 Then
       
        '______________optional size shaperange_______________
        'sr.SetSize , ActivePage.SizeHeight 'set only height
        'sr.SetSize ActivePage.SizeWidth 'set only width
       
        '________optional center the shaperange to pg ________
        sr.SetPositionEx cdrCenter, ActivePage.SizeWidth / 2, ActivePage.SizeHeight / 2
       
            ActiveDocument.Pages(1).Activate
            If ActivePage.Layers.Find("Layer_" & i) Is Nothing Then
                Set l = ActivePage.CreateLayer("Layer_" & i)
            Else
                Set l = ActivePage.Layers("Layer_" & i)
            End If
            sr.MoveToLayer l

        End If
    Next i
End Sub
  • Try this

    Sub pagesToLayers()
    Dim s As Shape, sr As ShapeRange
    Dim p As Page, i&, l As Layer

    For i = 1 To ActiveDocument.Pages.Count
    ActiveDocument.Pages(i).Activate
    Set sr = ActivePage.Shapes.All
    If sr.Count > 0 Then


    '______________modifying_______________
    Dim X As Double, Y As Double, Interv As Double
    For Each s In sr
    Interv = s.SizeHeight / 10
    s.SetPosition X, Y - Interv
    X = s.LeftX
    Y = s.BottomY
    Next s

    '______________optional size shaperange_______________
    'sr.SetSize , ActivePage.SizeHeight 'set only height
    'sr.SetSize ActivePage.SizeWidth 'set only width

    '________optional center the shaperange to pg ________
    sr.SetPositionEx cdrCenter, ActivePage.SizeWidth / 2, ActivePage.SizeHeight / 2

    ActiveDocument.Pages(1).Activate
    If ActivePage.Layers.Find("Layer_" & i) Is Nothing Then
    Set l = ActivePage.CreateLayer("Layer_" & i)
    Else
    Set l = ActivePage.Layers("Layer_" & i)
    End If
    sr.MoveToLayer l

    End If
    Next i
    End Sub


    Regards

    Taras

  • Here's one way to do it:

    Sub pagesToLayers()
        Dim s As Shape, sr As ShapeRange
        Dim p As Page, i&, l As Layer
        Dim dblPrevBottomY As Double
        Const dblVertGapTop As Double = 0.15
        Const dblVertGapBetween As Double = 0.3
       
        For i = 1 To ActiveDocument.Pages.Count
            ActiveDocument.Pages(i).Activate
            Set sr = ActivePage.Shapes.All
            If sr.Count > 0 Then
           
            '______________optional size shaperange_______________
            'sr.SetSize , ActivePage.SizeHeight 'set only height
            'sr.SetSize ActivePage.SizeWidth 'set only width
           
            '________optional center the shaperange to pg ________
            'sr.SetPositionEx cdrCenter, ActivePage.SizeWidth / 2, ActivePage.SizeHeight / 2
           
                ActiveDocument.Pages(1).Activate
                If ActivePage.Layers.Find("Layer_" & i) Is Nothing Then
                    Set l = ActivePage.CreateLayer("Layer_" & i)
                Else
                    Set l = ActivePage.Layers("Layer_" & i)
                End If
                sr.MoveToLayer l
                
                'center in X
                sr.CenterX = ActivePage.SizeWidth / 2
                
                If i = 1 Then
                    'first sr on page; reference to page top
                    sr.TopY = ActivePage.TopY - dblVertGapTop
                Else
                    'reference to most-recently-placed sr
                    sr.TopY = dblPrevBottomY - dblVertGapBetween
                End If
                
                dblPrevBottomY = sr.BottomY
    
            End If
        Next i
    End Sub
    
  • Is there a way to select the texts from top to bottom and combine them so they stay in order?

    I don't know if this is what you are looking for, but here is something that starts with individual Artistic text shapes, sorts them by TopY, and then combines them into a single Paragraph text shape:

    Sub combine_text_sort_by_TopY()
    Dim sr As ShapeRange
    Dim s As Shape
    
        Set sr = ActiveSelectionRange
        sr.Sort "@shape1.com.TopY < @shape2.com.TopY"
        For Each s In sr
            s.Text.ConvertToParagraph
        Next s
        sr.Combine
    End Sub