Printing Only Pages with Changes

[billbrandi]

After modifying a Word document and using the "track changes" option, is
there a way to print only those pages with changes (short of going through
the entire document and printing pages one by one)?

Thanks
Bill

 

[Doug Robbins - Word MVP]

If you run a macro containing the following code, it should only print the
pages on which there are revisions:

Dim revpage As Long, pageprint As Long
pageprint = 0
With ActiveDocument
For i = 1 To .Revisions.Count
.Revisions(i).Range.Select
Selection.Collapse wdCollapseStart
revpage = Selection.Information(wdActiveEndPageNumber)
If revpage > pageprint Then
pageprint = revpage
.PrintOut Pages:=pageprint
End If
Next i
End With

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[billbrandi]

Thanks. When I ran the macro I got an error number 13, type mismatch. Here
is the line where the error occured:

..PrintOut Pages:=pageprint

Not being familiar with macros I was unsure how resolve.

 

[Graham Mayor]

The following revised version should work:

Dim revpage As Long, pageprint As String
pageprint = 0
With ActiveDocument
For i = 1 To .Revisions.Count
.Revisions(i).Range.Select
Selection.Collapse wdCollapseStart
revpage = Selection.Information(wdActiveEndPageNumber)
If revpage > pageprint Then
pageprint = revpage
Else
GoTo Skip
End If
MsgBox pageprint
.PrintOut Range:=wdPrintRangeOfPages, Copies:=1, Pages:=pageprint
Skip:
Next i
End With


--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP

My web site www.gmayor.com

<>>< ><<> ><<> <>>< ><<> <>>< <>><<>

 

[David Campbell]

I have revised the code above so that it:

- ignores formatting changes (which I typically don't want printed
out)
- warns the user if the macro is likely to take a long time to run
- collates a list of pages to be printed, rather than printing the
pages one by one (useful if either your printer prints pages in
reverse order, like mine does, or if you are on an office network
where each print job comes with a header page)
- opens the print dialog, with the changed pages to be printed, so you
can change other settings if required.

Here's the code. Any comments welcome.

Sub PrintTrackedChanges()

Dim revpagestart As Long, revpageend As Long, pageprint As String,
changedpages As String

pageprint = 0
changedpages = ""

Application.ScreenUpdating = False

currentselectionstart = Application.Selection.Start
currentselectionend = Application.Selection.End


With ActiveDocument
If .Revisions.Count = 0 Then MsgBox ("There are no revisions in this
document"): GoTo Finish
If .Revisions.Count > 20 Then If MsgBox("There are" +
Str(.Revisions.Count) + " revisions in this document. Checking and
printing them may take some time. Continue?", vbYesNo) = vbNo Then
GoTo Finish

For i = 1 To .Revisions.Count
.Revisions(i).Range.Select
revpageend = Selection.Information(wdActiveEndPageNumber)
Selection.Collapse wdCollapseStart
revpagestart = Selection.Information(wdActiveEndPageNumber)

If .Revisions(i).Type = wdRevisionProperty Then GoTo Skip
If .Revisions(i).Type = wdRevisionParagraphProperty Then GoTo
Skip
If .Revisions(i).Type = wdRevisionSectionProperty Then GoTo
Skip

If pageprint >= revpageend Then GoTo Skip

If revpagestart = revpageend Then
changedpages = changedpages + Str(revpageend) + ", "
pageprint = revpageend
End If

If revpageend > revpagestart Then
changedpages = changedpages + Str(revpagestart) + "-" +
Str(revpageend) + ", "
pageprint = revpageend
End If
Skip:
Next i
End With

If changedpages = "" Then
MsgBox "There are no changed pages to print"
GoTo Finish
End If

changedpages = Left(changedpages, Len(changedpages) - 2)

With Dialogs(wdDialogFilePrint)
.Range = wdPrintRangeOfPages
.Pages = changedpages
.Show
End With

Finish:

Selection.SetRange Start:=currentselectionstart,
End:=currentselectionend
Application.ScreenUpdating = True

End Sub

 

[pksublime]

Another edit to always print page 1, something that most configuration management processes will require.

Sub PrintTrackedChanges(ByVal Control As IRibbonControl)

    Dim revpagestart As Long, revpageend As Long, pageprint As String, changedpages As String
    
    pageprint = 1
    changedpages = "1, "
    
    Application.ScreenUpdating = False
    
    currentselectionstart = Application.Selection.Start
    currentselectionend = Application.Selection.End
    
    
    With ActiveDocument
    If .Revisions.Count = 0 Then MsgBox ("There are no revisions in this Document "): GoTo Finish
    If .Revisions.Count > 20 Then If MsgBox("There are" + Str(.Revisions.Count) + _
        " revisions in this document. Checking and printing them may take some time. Continue?", vbYesNo) = vbNo Then GoTo Finish
    
    For i = 1 To .Revisions.Count
        .Revisions(i).Range.Select
        revpageend = Selection.Information(wdActiveEndPageNumber)
        Selection.Collapse wdCollapseStart
        revpagestart = Selection.Information(wdActiveEndPageNumber)
        
        If .Revisions(i).Type = wdRevisionProperty Then GoTo Skip
        If .Revisions(i).Type = wdRevisionParagraphProperty Then GoTo Skip
        If .Revisions(i).Type = wdRevisionSectionProperty Then GoTo Skip
        
        If pageprint >= revpageend Then GoTo Skip
        
        If revpagestart = revpageend Then
            changedpages = changedpages + Str(revpageend) + ", "
            pageprint = revpageend
        End If
        
        If revpageend > revpagestart Then
            If changedpages = "1, " And revpagestart = 1 Then
                changedpages = ""
            End If
            changedpages = changedpages + Str(revpagestart) + "-" + Str(revpageend) + ", "
            pageprint = revpageend
        End If
Skip:
    Next i
    End With
    
    If changedpages = "" Then
        MsgBox "There are no changed pages to print"
        GoTo Finish
    End If
    
    changedpages = Left(changedpages, Len(changedpages) - 2)
    
    With Dialogs(wdDialogFilePrint)
    .Range = wdPrintRangeOfPages
    .Pages = changedpages
    .Show
    End With
    
Finish:
    
    Selection.SetRange Start:=currentselectionstart, End:=currentselectionend
    Application.ScreenUpdating = True

End Sub