OberonPlace.com Forums - Copy Selected Objects to other pages maintaining layers

OberonPlace.com Forums (http://forum.oberonplace.com/index.php)

- Code Critique (http://forum.oberonplace.com/forumdisplay.php?f=25)

- - Copy Selected Objects to other pages maintaining layers (http://forum.oberonplace.com/showthread.php?t=2661)

Copy Selected Objects to other pages maintaining layers

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)

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:

Code:

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:

Code:

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:

Code:

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

Macro Updated - this time with code!

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:

Code:

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

Code:



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

Code:

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

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:

Code:

If expr = True Then ...

I would just use:

Code:

If expr Then ...

and vice versa, instead of:

Code:

If expr = False Then ...

use:

Code:

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").

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

Code:

ActiveDocument.MasterPage.Shapes.All

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:

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:

Code:

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"

I suppose an X6 update isn't a reasonable request...?

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