View Single Post
  #3  
Old 28-02-2007, 19:35
knowbodynow knowbodynow is offline
Senior Member
 
Join Date: Mar 2006
Location: Hatsukaichi near Hiroshima
Posts: 433
Default 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
Attached Images
  
Attached Files
File Type: gms copytonext.gms (79.0 KB, 1033 views)
Reply With Quote