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