Copy Selected Objects to other pages maintaining layers

[knowbodynow]

Hello,

The attached gms file is my crude attempt to offer a macro that will copy objects either to an existing page or to a new page, as determined by the user.
It's made with CorelDraw 12. I've tried to combine choice with ease of use. I wouldn't have got as far as I have with this without the help of Shelby. I'd be grateful for suggestions as to how to make this macro function better. My coding is very rough. This is the first time I've uploaded something so please be gentle!

Thanks,

Chris (Hunt)

[Alex]

Chris,

It's best if you also post the actual code here. It's easier for people to comment on the code they can see rather than having to download something...

Anyway, for the rest of folks, here is the code.

start module:

Sub copytonext()

 If ActiveDocument Is Nothing Then
 MsgBox "Cannot Run Macro - No open Document", vbCritical
 Exit Sub
 End If

'test to see if any objects selected

If Not ActiveSelection.Shapes.count > 0 Then

response = MsgBox("Select All Objects Not On Master layers?", vbYesNo, "No Objects selected!")
                  
       If response = vbYes Then
       
   Dim srToSelect As ShapeRange
   Set srToSelect = ActivePage.Shapes.All
   srToSelect.RemoveRange ActiveDocument.Pages(0).Shapes.All
   srToSelect.CreateSelection
                 
       frmcopytonext.Show vbModal
                 
       ElseIf response = vbNo Then
       Exit Sub
       End If
       
End If

'test to see if all objects on master pages

    Dim sr As ShapeRange
    Dim s As Shape
    Dim mcount As Integer

    Set sr = ActiveSelectionRange
    mcount = 0
    
    For Each s In sr
        If s.Layer.Master Then mcount = mcount + 1
    Next s
    
If ActiveSelection.Shapes.count = mcount Then

MsgBox "Check Selection - cannot process objects on masterpages, quitting"
Exit Sub

End If

frmcopytonext.Show vbModal

End Sub

frmaskpage form:

Public pn As String

Private Sub Cmd_OK_Click()

Dim sr As ShapeRange
Dim s As Shape
Dim p As Page

pn = Val(pagenumber)

'rough test to see if actual numerical value typed

If Not pn > 0 Then

MsgBox "Please Check Input!"
Unload Me
Exit Sub

End If

'tests to see if user entered number is higher than number of existing pages

If pn > ActiveDocument.Pages.count Then
MsgBox "Check Page Numbers - input too high!"
Unload Me
Exit Sub
End If


'inserts new page, copies objects to it and then moves it

If frmcopytonext.Optnewask = True Then 'tests user choice from first form

    Set sr = ActiveSelectionRange
    Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)

    For Each s In sr
        s.Layer.Activate
        s.Duplicate
        s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    Next s
    

ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (pn)
ActiveDocument.Pages(pn).Activate

Unload Me
Exit Sub

End If


'copies objects to desired page

If frmcopytonext.Optask = True Then ''tests user choice from first form

Set sr = ActiveSelectionRange

For Each s In sr
s.Layer.Activate
s.Duplicate

s.MoveToLayer ActiveDocument.Pages(pn).ActiveLayer
Next s

ActiveDocument.Pages(pn).Activate

Unload Me

End If

End Sub

frmcopytonext form:

Private Sub Cmd_OK_Click()

Dim sr As ShapeRange
Dim s As Shape
Dim p As Page
Dim L As Layer
Dim vNewName As String
Dim pn As String


If Optnew = True Then

    Set sr = ActiveSelectionRange
    Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)

    For Each s In sr
        s.Layer.Activate
        s.Duplicate
        s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    Next s

ActiveDocument.Pages(ActivePage.Index + 1).Activate
Unload Me
Exit Sub

End If


'Inserts Page, copies objects to that page then moves that page to end of document

If Optlast = True Then

    Set sr = ActiveSelectionRange
    Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)

    For Each s In sr
        s.Layer.Activate
        s.Duplicate
        s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    Next s
    
C = ActiveDocument.Pages.count


ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (C)
ActiveDocument.Pages(C).Activate

Unload Me
Exit Sub

End If


'Inserts Page, copies objects to that page then moves that page to beginning of document

If Optfirst = True Then

    Set sr = ActiveSelectionRange
    Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)

    For Each s In sr
        s.Layer.Activate
        s.Duplicate
        s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    Next s
    

ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (1)
ActiveDocument.Pages(1).Activate

Unload Me
Exit Sub

End If


'Uses second form to get page number, inserts page, copies objects to that page then moves it to chosen location

If Optnewask = True Then

frmaskpage.Show vbModal

Unload Me
Exit Sub

End If


'tests to see if user is already on the last page

If Optnext = True Then

If ActivePage.Index = ActiveDocument.Pages.count Then
MsgBox "Last Page - Cannot copy to next page"
Unload Me
Exit Sub
End If

ActiveShape.Layer.Activate

Set sr = ActiveSelectionRange

For Each s In sr
s.Layer.Activate
s.Duplicate
s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
ActiveDocument.Pages(ActivePage.Index + 1).Activate
Unload Me
Exit Sub

Next s

End If

'Uses second form to get page number to copy objects to

If Optask = True Then

frmaskpage.Show vbModal

Unload Me
Exit Sub

End If


End Sub

Private Sub cmd_cancel_Click()

Unload Me
Exit Sub

End Sub

[knowbodynow]

Sorry Alex,

I didn't think of pasting the graphics and putting the form code separately. Here is a revised version that gives users the option to move objects instead of copying them.

Chris

Start module:

Sub copytonext()

 If ActiveDocument Is Nothing Then
 MsgBox "Cannot Run Macro - No open Document", vbCritical
 Exit Sub
 End If
 
 
'test to see if any objects exist on page

If ActivePage.Shapes.Count = 0 Then
MsgBox "Cannot Run Macro - No Objects To Copy", vbCritical
Exit Sub
End If
 

'test to see if any objects selected

If Not ActiveSelection.Shapes.Count > 0 Then

response = MsgBox("Select All Objects Not On Master layers?", vbYesNo, "No Objects selected!")
                  
   If response = vbYes Then
       
   Dim srToSelect As ShapeRange
   Set srToSelect = ActivePage.Shapes.All
   srToSelect.RemoveRange ActiveDocument.Pages(0).Shapes.All
   srToSelect.CreateSelection
                 
   frmcopytonext.Show vbModal
                 
   ElseIf response = vbNo Then
   Exit Sub
   End If
       
End If


'test to see if all objects selected on master pages

   Dim sr As ShapeRange
   Dim s As Shape
   Dim mcount As Integer

   Set sr = ActiveSelectionRange
   mcount = 0
    
   For Each s In sr
       If s.Layer.Master Then mcount = mcount + 1
   Next s
    
If ActiveSelection.Shapes.Count = mcount Then
MsgBox "Check Selection - cannot process objects on masterpages, quitting"
Exit Sub
End If


'Select is made and checked so show form

frmcopytonext.Show vbModal

End Sub

frmcopytonext form

Private Sub Cmd_OK_Click()

Dim sr As ShapeRange
Dim s As Shape
Dim p As Page
Dim L As Layer
Dim vNewName As String
Dim pn As String

'Togglebutton1 allows user to move objects rather than copy them
'If false (the default) objects are copied

If ToggleButton1 = False Then 'ToggleButton1 start

'Inserts Page after current page, copies objects to that page

    If Optnewnext = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.Duplicate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
    
    ActiveDocument.Pages(ActivePage.Index + 1).Activate
    Unload Me
    Exit Sub
    
    End If


'Inserts Page, copies objects to that page then moves that page to end of document

    If Optnewlast = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.Duplicate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    C = ActiveDocument.Pages.Count
    
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (C)
    ActiveDocument.Pages(C).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Inserts Page, copies objects to that page then moves that page to beginning of document

    If Optnewfirst = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.Duplicate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (1)
    ActiveDocument.Pages(1).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Uses second form to get page number, inserts page, copies objects to that page
'then copies it to chosen location

    If Optnewask = True Then
    
    frmaskpage.Caption = "Insert New Page - Where?"
    frmaskpage.Label1 = "Copy to:"
    
    frmaskpage.Show vbModal
    
    Unload Me
    Exit Sub
    
    End If


'copies objects to next page if it exists
'first tests to see if user is already on the last page

    If Optnext = True Then
    
        If ActivePage.Index = ActiveDocument.Pages.Count Then
        MsgBox "Last Page - Cannot copy to next page"
        Unload Me
        Exit Sub
        End If
    
    ActiveShape.Layer.Activate
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.Duplicate
    s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    ActiveDocument.Pages(ActivePage.Index + 1).Activate
    
    Next s
    
    Unload Me
    Exit Sub
    
    End If


'copies objects to first page

    If Optfirst = True Then
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.Duplicate
    s.MoveToLayer ActiveDocument.Pages(1).ActiveLayer
    ActiveDocument.Pages(1).Activate
    Next s
    
    Unload Me
    Exit Sub
    
    End If


'copies objects to last page

    If Optlast = True Then
    
    C = ActiveDocument.Pages.Count
    
        Set sr = ActiveSelectionRange
       
        For Each s In sr
            s.Layer.Activate
            s.Duplicate
            s.MoveToLayer ActiveDocument.Pages(C).ActiveLayer
        Next s
    
    ActiveDocument.Pages(C).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Uses second form to get page number to copy objects to

    If Optask = True Then
    
    frmaskpage.Caption = "Copy Objects To Which Page?"
    frmaskpage.Label1 = "Page:"
    
    frmaskpage.Show vbModal
    
    Unload Me
    Exit Sub
    
    End If


'If togglebutton is true then objects are moved rather than copied

ElseIf ToggleButton1 = True Then

'Inserts Page, moves objects to that page

    If Optnewnext = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
    
    ActiveDocument.Pages(ActivePage.Index + 1).Activate
    Unload Me
    Exit Sub
    
    End If


'Inserts Page, moves objects to that page then moves that page to end of document

    If Optnewlast = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    C = ActiveDocument.Pages.Count
    
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (C)
    ActiveDocument.Pages(C).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Inserts Page, moves objects to that page then moves that page to beginning of document

    If Optnewfirst = True Then
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (1)
    ActiveDocument.Pages(1).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Uses second form to get page number, inserts page,
'moves objects to that page then moves it to chosen location

    If Optnewask = True Then
    
    frmaskpage.Caption = "Insert New Page - Where?"
    frmaskpage.Label1 = "Move to:"
    
    frmaskpage.Show vbModal
    
    Unload Me
    Exit Sub
    
    End If


'tests to see if user is already on the last page

    If Optnext = True Then
    
        If ActivePage.Index = ActiveDocument.Pages.Count Then
        MsgBox "Last Page - Cannot Move to next page"
        Unload Me
        Exit Sub
        End If
    
    ActiveShape.Layer.Activate
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
    ActiveDocument.Pages(ActivePage.Index + 1).Activate
    
    Next s
    
    Unload Me
    Exit Sub
    
    End If


'moves objects to first page

    If Optfirst = True Then
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.MoveToLayer ActiveDocument.Pages(1).ActiveLayer
    ActiveDocument.Pages(1).Activate
    Next s
    
    Unload Me
    Exit Sub
    
    End If


'moves objects to last page

    If Optlast = True Then
    
    C = ActiveDocument.Pages.Count
    
        Set sr = ActiveSelectionRange
       
        For Each s In sr
            s.Layer.Activate
            s.MoveToLayer ActiveDocument.Pages(C).ActiveLayer
        Next s
    
    ActiveDocument.Pages(C).Activate
    
    Unload Me
    Exit Sub
    
    End If


'Uses second form to get page number to move objects to

    If Optask = True Then
    
    frmaskpage.Caption = "Move Objects To Which Page?"
    frmaskpage.Label1 = "Page:"
    
    frmaskpage.Show vbModal
    
    Unload Me
    Exit Sub
    
    End If

End If 'ToggleButton1 end

End Sub

Private Sub cmd_cancel_Click()

Unload Me
Exit Sub

End Sub


Private Sub ToggleButton1_Change()

'this alows the user to move objects rather than copy them.
'this sub updates the apperance of the form

If ToggleButton1.Value = False Then
  
  Label1 = "Copy Objects To Existing Page"
  Optnext.Caption = "Copy To next page"
  Optfirst.Caption = "Copy to first page"
  Optlast.Caption = "Copy To last page"
  Optask.Caption = "Choose Page To Copy To"
  Label2 = "Copy Objects To New Page"
  Optnewnext.Caption = "Insert New Page after current page"
  Optnewfirst.Caption = "Insert New Page at start of document"
  Optnewlast.Caption = "Insert New Page at end of document"
  Optnewask.Caption = "Choose Where to insert page"
  frmaskpage.Caption = "Copy To Which Page?"

ElseIf ToggleButton1.Value = True Then

  Label1 = "Move Objects To Existing Page"
  Optnext.Caption = "Move To next page"
  Optfirst.Caption = "Move to first page"
  Optlast.Caption = "Move To last page"
  Optask.Caption = "Choose Page To Move To"
  Label2 = "Move Objects To New Page"
  Optnewnext.Caption = "Insert New Page after current page"
  Optnewfirst.Caption = "Insert New Page at start of document"
  Optnewlast.Caption = "Insert New Page at end of document"
  Optnewask.Caption = "Choose Where to insert page"
  frmaskpage.Caption = "Move To Which Page?"

End If

End Sub

frmaskpage form

Private Sub Cmd_OK_Click()

Dim sr As ShapeRange
Dim s As Shape
Dim p As Page

pn = Val(pagenumber)

'rough test to see if actual numerical value typed

If Not pn > 0 Then

MsgBox "Please Check Input!"
Unload Me
Exit Sub

End If

'tests to see if user entered number is higher than number of existing pages

If pn > ActiveDocument.Pages.Count Then
MsgBox "Check Page Numbers - input too high!"
Unload Me
Exit Sub
End If


'ToggleButton1 allows user to move objects rather than copy them
'If ToggleButton1 is false (default) objects are copied)

If frmcopytonext.ToggleButton1 = False Then 'ToggleButton1 start

'inserts new page, copies objects to it and then moves it

    If frmcopytonext.Optnewask = True Then 'tests user choice from first form
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.Duplicate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (pn)
    ActiveDocument.Pages(pn).Activate
    
    Unload Me
    Exit Sub
    
    End If


'copies objects to chosen page

    If frmcopytonext.Optask = True Then 'tests user choice from first form
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.Duplicate
    
    s.MoveToLayer ActiveDocument.Pages(pn).ActiveLayer
    Next s
    
    ActiveDocument.Pages(pn).Activate
    
    Unload Me
    
    End If
    
    
'If ToggleButton1 is true objects are moved rather than copied

ElseIf frmcopytonext.ToggleButton1 = True Then

'inserts new page, moves objects to it and then moves page to chosen location

    If frmcopytonext.Optnewask = True Then 'tests user choice from first form
    
        Set sr = ActiveSelectionRange
        Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
        For Each s In sr
            s.Layer.Activate
            s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
        Next s
        
    
    ActiveDocument.Pages(ActivePage.Index + 1).MoveTo (pn)
    ActiveDocument.Pages(pn).Activate
    
    Unload Me
    Exit Sub
    
    End If


'moves objects to desired page

    If frmcopytonext.Optask = True Then ''tests user choice from first form
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr
    s.Layer.Activate
    s.MoveToLayer ActiveDocument.Pages(pn).ActiveLayer
    Next s
    
    ActiveDocument.Pages(pn).Activate
    
    Unload Me
    
    End If
    
End If 'ToggleButton1 End

End Sub

[Alex]

Let me post a few general comments about this code. Let's start with some comparison statements. I'd never compare Booleans to their actual values. Instead of:

If expr = True Then ...

I would just use:

If expr Then ...

and vice versa, instead of:

If expr = False Then ...

use:

If Not expr Then ...

It's shorter and a bit less error prone (some methods might return values other than True [-1] or False [0] as a Boolean value and comparing it to True will not work, however using just "If expr Then" will succeed for any non-zero value of "expr").

[Alex]

Instead of using Document.Pages(0) to access the master page you can now use Document.MasterPage which is more intuitive:

ActiveDocument.MasterPage.Shapes.All

[Alex]

I would try to rely less on the current state of the application. Meaning, less use of "activepage", "activelayer" and so on.

Also, when you duplicate the objects, you are actually moving the original objects and leave the duplicates on the current page.

Compare your code:

Set sr = ActiveSelectionRange
Set p = ActiveDocument.InsertPages(1, False, ActivePage.Index)
    
For Each s In sr
    s.Layer.Activate
    s.Duplicate
    s.MoveToLayer ActiveDocument.Pages(ActivePage.Index + 1).ActiveLayer
Next s
    
ActiveDocument.Pages(ActivePage.Index + 1).Activate

To something like this:

Dim PageNext As Page
Dim sDuplicate As Shape

Set sr = ActiveSelectionRange
Set PageNext = ActiveDocument.InsertPages(1, False, ActivePage.Index)

For Each s In sr
    Set sDuplicate = s.Duplicate
    sDuplicate.MoveToLayer PageNext.Layers(s.Layer.Name)
Next s

Since I never activated the current layer a shape is on, there is no need to restore the newly added page as the current one. Anyway, you can see that the new version is much more simplified and it doesn't rely on anything being "active" or "current"

[Hockeyrink]

My VBA-fu is practically nonexistent. This macro seems to run fine, but it ends up shoving all the elements onto a single layer, not throwing an error I can attempt to debug.

Any chance somebody can give this a boo and update it? I find it very frustrating to lose all my carefully-arrange layers on a cut/paste between layers!

Thanks
Dave