View Single Post
  #2  
Old 28-02-2007, 12:23
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

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
Attached Images
  
Reply With Quote