'============================================================================
'****************************************************************************
'************************  SmartExtract  ********************************
'****************************************************************************
'============================================================================

Sub wrkSmartExtract()
'=================================================================================================
'Extracts Comments and revisions from a source document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Finds the property containing the name of the source
'Source must be open, the tries to find the page number in the current paragraph
'Then goes to source and then to page
'UPDATED May - Added ability to get extract type
'=================================================================================================
    Dim dSrcDoc As Document
    Dim dExtractDoc As Document
    Dim iCnt As Integer
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim bResetTrackChg As Boolean
 
    Dim iChgArray() As Long 'Col 1=Para Num, Col 2=Type(1=Rev,2=Cmt), 3=Index, 4=Start Pos, 5 = length (highlight)
    Dim iParaNum As Long
    Dim iType As Long
    Dim iIndex As Long
    Dim bMinorRevChg As Boolean
    
    Dim tExtTbl As Table
    Dim iTblRow As Integer
    Dim rTblRow As Row
    Dim bAddTableRow As Boolean
    
    Dim sAuthor As String
    Dim rChgRng As Range
    Dim sChgHdr As String
    Dim sChgText As String
    Dim iChgCnt As Integer
    Dim iMinorRevLen As Integer
    Dim iPageFormatLen As Integer

    Dim sCtxHdr As String
    Dim rCtxRng As Range
    Dim iCtxTblRow As Integer
    Dim sCtxRowCell1Text As String
    Dim bCtxWholePara As Boolean
    
    Dim bExtractComments As Boolean
    Dim bExtractRevisions As Boolean
    Dim bExtractHighlights As Boolean
    Dim sExtractAuthors As String
    Dim iHighlightCnt As Integer
    
    Set dSrcDoc = ActiveDocument
        
    'Added call to get extract type
    Call wrkGetExtractType(sExtractAuthors, bExtractComments, bExtractRevisions, bExtractHighlights, iHighlightCnt)
    If sExtractAuthors = "No Extract" Then Exit Sub
    
    'Here if valid
    Application.ScreenUpdating = False
    bResetTrackChg = False
    
    'Need to set this off so the cut and paste gets carries teh inserts and deletions
    If ActiveDocument.TrackRevisions = True Then
        ActiveDocument.TrackRevisions = False
        bResetTrackChg = True
    End If
    
    If dSrcDoc.Range.Information(wdNumberOfPagesInDocument) >= 100 Then
        iPageFormatLen = 3
    ElseIf dSrcDoc.Range.Information(wdNumberOfPagesInDocument) >= 10 Then
        iPageFormatLen = 2
    Else: iPageFormatLen = 1
    End If
         
    'Load the comments and revisons into the arrary, then sort into order in document
    ReDim iChgArray((dSrcDoc.Comments.Count + dSrcDoc.Revisions.Count + iHighlightCnt), 5)
    Call wrkPrepChgArray(dSrcDoc, sExtractAuthors, bExtractComments, bExtractRevisions, bExtractHighlights, iChgCnt, iChgArray())
    
    'Add New Document and insert the header infromation
    Set dExtractDoc = Documents.Add
    dExtractDoc.PageSetup.Orientation = wdOrientLandscape
    sChgHdr = "Comments extracted from:  " & dSrcDoc.Name & vbCr
    dExtractDoc.Range.Select
    Selection.InsertBefore (sChgHdr)
    Selection.Collapse (wdCollapseEnd)

    'Insert a 5-column table for the comments
    With dExtractDoc
        Set tExtTbl = .Tables.Add _
             (Range:=Selection.Range, numrows:=iChgCnt + 1, NumColumns:=5)
    End With
    'Now prepare the table for the revisions to be added into
    Call wrkSetupTable(tExtTbl)

    'Main routing
    iParaNum = 0
    iTblRow = 0
    iMinorRevLen = 6
    bCtxWholePara = True
    
    For iCnt = 1 To iChgCnt ' for each change
        'get the array values
        StatusBar = "Processing Extract " & iCnt & " of " & iChgCnt
        If iChgArray(iCnt, 1) = 0 Then Exit For 'got to the last row
        iType = iChgArray(iCnt, 2)
        iIndex = iChgArray(iCnt, 3)
        bAddTableRow = True
        sAuthor = ""
        
        If iType = 1 Then Set rRev = dSrcDoc.Revisions(iIndex)
        If iType = 2 Then Set cCmt = dSrcDoc.Comments(iIndex)
        
        'If this is a new paragrah in the sorted array, get the context of the change or comment
        If iParaNum <> iChgArray(iCnt, 1) Then
            iParaNum = iChgArray(iCnt, 1)
            bCtxWholePara = True
            bMinorRevChg = False
            If iType = 1 Then rRev.Range.Select
            If iType = 2 Then cCmt.Scope.Select
            If iType = 3 Then
                dSrcDoc.Range(iChgArray(iCnt, 4), iChgArray(iCnt, 4) + iChgArray(iCnt, 5)).Select
                
            End If
            'Get the contex
            sCtxHdr = "Page " & wrkPadLeftSpaces(Selection.Information(wdActiveEndPageNumber), iPageFormatLen) & ": Line " & wrkPadLeftSpaces(Selection.Information(wdFirstCharacterLineNumber), 2)
            If Selection.Information(wdWithInTable) Then
                iCtxTblRow = Selection.Information(wdStartOfRangeRowNumber)
                 sCtxRowCell1Text = wrkGetCtxRowCell1Text(iCtxTblRow)
                If Len(sCtxRowCell1Text) > 20 Then sCtxRowCell1Text = Left(sCtxRowCell1Text, 20) & "..."
                sCtxHdr = sCtxHdr & "  Table Row: " & sCtxRowCell1Text
                Set rCtxRng = Selection.Cells(1).Range
            Else
                Set rCtxRng = wrkGetParaBasedCtxRng(dSrcDoc, Selection.Range, bCtxWholePara)
            End If
        End If ' New Para
        
        'now process revisions
        Select Case iType
        Case 1 'revision
            With rRev
                sAuthor = .Author
                If Len(.Range.Text) <= iMinorRevLen Then 'is this a minor change?
                    If bMinorRevChg = False Then 'Initial Minor Change
                        bMinorRevChg = True
                        sChgHdr = "Minor Revision:"
                        Call wrkGetMinorChg(dSrcDoc, iChgArray(), iCnt, iChgCnt, iMinorRevLen, sChgText)
                    Else
                        bAddTableRow = False ' second minor change found
                    End If ' first minor change for para
                Else 'Major Change found
                    If .Type = wdRevisionInsert Then
                        sChgHdr = "Inserted:"
                    Else
                        sChgHdr = "Deleted:"
                    End If
                    sChgText = .Range.Text
                End If 'Major Change found
            End With 'rRev
        Case 2  'now process comments
            With cCmt
                sAuthor = .Author
                sChgHdr = "Comment " & .Initial & .Index & ":"
                sChgText = .Range.Text
            End With
        Case 3
            If iCnt > 1 Then
                If iChgArray(iCnt - 1, 4) = iChgArray(iCnt, 4) Then bAddTableRow = False 'Skip Highlight on inserted
            End If ' test if not first row
            sChgHdr = "Highlighted Text:"
            dSrcDoc.Range(iChgArray(iCnt, 4), iChgArray(iCnt, 4) + iChgArray(iCnt, 5)).Select
            sChgText = Selection.Range.Text
            
        End Select
        
        'If a row in the results table is to be added - wont add of not first minor change
        If bAddTableRow Then
            iTblRow = iTblRow + 1
            'Prepare the table entry
            With tExtTbl.Rows(iTblRow + 1)
                .Cells(1).Range.Text = iTblRow
                
                '--- Cell 2 ---
                Call wrkSelectCtxRange(rCtxRng, dSrcDoc, iParaNum)
                .Cells(2).Range.Paste
                If Not bCtxWholePara Then .Cells(2).Range.InsertBefore "     ..."
                .Cells(2).Range.InsertBefore sCtxHdr & vbCr
                'now remove bullets and lists and underline
                If .Cells(2).Range.Paragraphs(1).Range.ListFormat.ListType <> wdListNoNumbering Then _
                        .Cells(2).Range.Paragraphs(1).Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
                If .Cells(2).Range.Paragraphs(1).Range.HighlightColorIndex <> wdNoHighlight Then _
                        .Cells(2).Range.Paragraphs(1).Range.HighlightColorIndex = wdNoHighlight
                
                .Cells(2).Range.Paragraphs(1).Range.Font.Underline = wdUnderlineSingle
                '--- Cell 3 ---
                .Cells(3).Range.Text = sChgHdr & vbCr & sChgText
                .Cells(3).Range.Paragraphs(1).Range.Font.Underline = wdUnderlineSingle
                '--- Cell 4 ---
                .Cells(4).Range.Text = sAuthor
             End With
        End If 'adding table Row
    Next iCnt
    
    dSrcDoc.Activate
    Selection.HomeKey Unit:=wdStory
    ActiveWindow.View.ShowRevisionsAndComments = True
    
    If bResetTrackChg Then ActiveDocument.TrackRevisions = True
    dExtractDoc.Activate
        
    iCnt = 0 'Remove blank rows in the talble
    Do While tExtTbl.Rows.Last.Cells(1).Range.Characters.Count <= 1
        'until first non null row found
        tExtTbl.Rows.Last.Delete
        iCnt = iCnt + 1
        StatusBar = "Blank Table Row" & iCnt
    Loop
        
    'Remove source formatting in context col
    StatusBar = "Formatting Extract"
    tExtTbl.Columns(1).Select
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    tExtTbl.Columns(2).Select
    With Selection
        .ParagraphFormat.Alignment = wdAlignParagraphLeft
        .Font.Size = 9
        .Font.Bold = False
        .ParagraphFormat.SpaceBefore = 0
        .ParagraphFormat.SpaceBefore = 0
    End With
    tExtTbl.Rows(1).Range.Font.Bold = True
    
    'Mark scope of comments and then delete them
    For Each cCmt In dExtractDoc.Comments
        cCmt.Scope.HighlightColorIndex = wdGray25
    Next cCmt
    Do While dExtractDoc.Comments.Count >= 1
        dExtractDoc.Comments(1).Delete
    Loop
    Call wrkAcceptAllFormatChanges("No Prompt")
    
    'Done
    Application.ScreenUpdating = True
    dExtractDoc.CustomDocumentProperties.Add Name:="dpSmartExtractSource", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=dSrcDoc.Name
    Selection.HomeKey Unit:=wdStory

    MsgBox tExtTbl.Rows.Count - 1 & " entries written", , "SmartExtract"

End Sub
Function wrkPadLeftSpaces(vSource As Variant, iPadLength As Integer) As String
    wrkPadLeftSpaces = Right((Space(iPadLength) & vSource), iPadLength)
End Function
Function wrkGetCtxRowCell1Text(iCtxTblRow As Integer) As String
    'Separate routine so that if there are merged cells in the table, no error is generated
    wrkGetCtxRowCell1Text = iCtxTblRow
    On Error Resume Next
    wrkGetCtxRowCell1Text = wrkGetCellText(Selection.Tables(1).Rows(iCtxTblRow).Cells(1).Range)
End Function
Function wrkGetParaBasedCtxRng(dSrcDoc As Document, rChgRng, bCtxWholePara As Boolean) As Range
'=================================================================================================
'Ensures that there is at least 150 characters of context
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Keeps adding paragraphs to the context until there are at least 150 characters in the context
' Assumes not in a table
'=================================================================================================
    Dim iStartPara As Long
    Dim iEndPara As Long
    Dim iChgStart As Long
    Dim iStartCtx As Long
    Dim iMinCtx As Long
    Dim iMaxCtx As Long
    Dim iReposCtx As Long
    
    
    iMinCtx = 30 ' min words in context
    iMaxCtx = 80 ' max words
    
    'set the start point for the change
    iChgStart = ActiveDocument.Range(0, rChgRng.Start).Words.Count
    
    'now get the paragraph range that the change occurs in
    Set wrkGetParaBasedCtxRng = rChgRng
    wrkGetParaBasedCtxRng.Select
    iStartPara = wrkGetParaNumSelection
    iEndPara = wrkGetParaNumSelection("End")
    
    'Now select the paragraph range
    wrkGetParaBasedCtxRng.SetRange Start:=dSrcDoc.Paragraphs(iStartPara).Range.Start, End:=dSrcDoc.Paragraphs(iEndPara).Range.End
    iStartCtx = ActiveDocument.Range(0, wrkGetParaBasedCtxRng.Start).Words.Count
    
    'now loop adding paragraphs
    Do While iStartPara > 1 And (iChgStart - iStartCtx) < iMinCtx
       If dSrcDoc.Paragraphs(iStartPara - 1).Range.Information(wdWithInTable) Then Exit Do
       iStartPara = iStartPara - 1
       wrkGetParaBasedCtxRng.SetRange Start:=dSrcDoc.Paragraphs(iStartPara).Range.Start, End:=wrkGetParaBasedCtxRng.End
       iStartCtx = ActiveDocument.Range(0, wrkGetParaBasedCtxRng.Start).Words.Count
    Loop
    If (iChgStart - iStartCtx) > iMaxCtx Then
        iReposCtx = (iChgStart - iMaxCtx) - iStartCtx
        wrkGetParaBasedCtxRng.MoveStart Unit:=wdWord, Count:=iReposCtx
         bCtxWholePara = False
    End If
End Function

Private Sub wrkGetMinorChg(dSrcDoc As Document, iChgArray() As Long, iCnt As Integer, iChgCnt As Integer, _
                            iMinorRevLen As Integer, sChgText As String)
'=================================================================================================
'Reads all changes for the same para and builds a string of minor changes
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'=================================================================================================
    Dim iNext As Long
    Dim iCurPara As Long
    Dim rChgRng As Range
       
    'First minor change
    iNext = iCnt
    iCurPara = iChgArray(iNext, 1)
    sChgText = dSrcDoc.Revisions(iChgArray(iNext, 3)).Range.Text
    
    iNext = iNext + 1
    Do
        If iNext > iChgCnt Then Exit Do ' - exits to handle last change
        If iChgArray(iNext, 1) <> iCurPara Then Exit Do 'next parra found - exits to handle last para in doc
        If iChgArray(iNext, 5) <= iMinorRevLen And iChgArray(iNext, 2) = 1 Then 'minor revision
            sChgText = sChgText & vbCr & dSrcDoc.Revisions(iChgArray(iNext, 3)).Range.Text
        End If
        iNext = iNext + 1
    Loop

End Sub

Private Sub wrkSelectCtxRange(rCtx As Range, dDoc As Document, iPara As Long)
'=================================================================================================
'Gets the range of the context
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Has complex logic to handle changes arising from whole table row deleted
'=================================================================================================
    On Error GoTo CopyError
    rCtx.Copy
    Exit Sub ' simple copy worked fine - main flow
    'If the Ctx range cannot be copied - Cused by:1-whole table row deleted
CopyError:
    iPara = iPara - 1 ' error found - get the prev para
    Resume TryPrevPara
TryPrevPara:
    On Error GoTo CopyError
    dDoc.Paragraphs(iPara).Range.Copy
End Sub
Private Sub wrkSetupTable(tTable As Table)
'=================================================================================================
'Sets up the table where the extracts are loaded
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'=================================================================================================
    With tTable
        If .Style <> "Table Grid" Then
            .Style = "Table Grid"
        End If
        .Rows.AllowBreakAcrossPages = False
        .Range.Style = wdStyleNormal
        .Range.Font.Size = 9
        .AllowAutoFit = False
        .PreferredWidthType = wdPreferredWidthPercent
        .PreferredWidth = 100
        .Columns.PreferredWidthType = wdPreferredWidthPercent
        .Columns(1).PreferredWidth = 5
        .Columns(2).PreferredWidth = 40
        .Columns(3).PreferredWidth = 30
        .Columns(4).PreferredWidth = 10
        .Columns(5).PreferredWidth = 15
        .Rows(1).HeadingFormat = True
        If .Rows(1).Shading.BackgroundPatternColor = wdColorAutomatic Then
             .Rows(1).Shading.BackgroundPatternColor = wdColorGray10
        End If
    End With

    'Insert table headings
    With tTable.Rows(1)
        .Range.Font.Bold = True
        .Cells(1).Range.Text = "Item"
        .Cells(2).Range.Text = "Context"
        .Cells(3).Range.Text = "Comment or Revision"
        .Cells(4).Range.Text = "Author"
        .Cells(5).Range.Text = "Action"
   End With
End Sub
Private Sub wrkPrepChgArray(dDoc As Document, sExtractAuthors As String, bExtractComments As Boolean, _
                          bExtractRevisions As Boolean, bExtractHighlights As Boolean, iChgCnt As Integer, iChgArray() As Long)
'=================================================================================================
'Loads an arrary of changes - revisions, then comments, then sorts them into order in document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Skips all revisions except insertions and deletions
'Skips Table of contents changes
'UPDATED May 15 - to include flags for each type of extract
'=================================================================================================
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim iParaNum As Long
    Dim bIncludeItem As Boolean
    Dim iCharNum As Long
    Dim sChgText As String
    Dim iPrevHighlightChar As Long
    Dim rHighlightRng As Range
    Dim iHighlightPrevStart As Long
       
    'Found instances of deleted revisions not seen in the UI haning around in the document - skip them
    On Error GoTo SkipDeletedRevisions
    iChgCnt = 0
    If bExtractRevisions Then
        For Each rRev In dDoc.Revisions
            With rRev
                bIncludeItem = False
                'Only include insertions and deletions
                If .Type = wdRevisionInsert Or .Type = wdRevisionDelete Then bIncludeItem = True
                'Exclude Author if not wanted
                If bIncludeItem Then
                    If sExtractAuthors <> "ALL" Then
                        If InStr(sExtractAuthors, .Author) = 0 Then bIncludeItem = False
                    End If
                End If
                
                'Skip contents changes
                If bIncludeItem Then 'First para may not be TOC in some scenarios
                    If InStr(.Range.Paragraphs(1).Style, "TOC") > 0 Then bIncludeItem = False
                End If
                If bIncludeItem And .Range.Paragraphs.Count >= 2 Then 'First para may not be TOC in some scenarios
                    If InStr(.Range.Paragraphs(2).Style, "TOC") > 0 Then bIncludeItem = False
                End If
                
                If bIncludeItem Then
                    iChgCnt = iChgCnt + 1
                    StatusBar = "Preparing Revsions. Item " & iChgCnt
    
                    .Range.Select
                    iParaNum = wrkGetParaNumSelection
                    iCharNum = Selection.Start
                    iChgArray(iChgCnt, 1) = iParaNum
                    iChgArray(iChgCnt, 2) = 1
                    iChgArray(iChgCnt, 3) = .Index
                    iChgArray(iChgCnt, 4) = iCharNum
                    iChgArray(iChgCnt, 5) = Len(.Range.Text)
                End If
            End With
        Next rRev
    End If
SkipDeletedRevisions:
    
    If bExtractComments Then
        For Each cCmt In dDoc.Comments
            With cCmt
                bIncludeItem = True
                If sExtractAuthors <> "ALL" Then
                    If InStr(sExtractAuthors, .Author) = 0 Then
                        bIncludeItem = False
                    End If
                End If
                If bIncludeItem Then
                    iChgCnt = iChgCnt + 1
                    StatusBar = "Preparing Comments, Item " & iChgCnt
                    .Scope.Select
                    iParaNum = wrkGetParaNumSelection
                    iCharNum = Selection.Start
                    iChgArray(iChgCnt, 1) = iParaNum
                    iChgArray(iChgCnt, 2) = 2
                    iChgArray(iChgCnt, 3) = .Index
                    iChgArray(iChgCnt, 4) = iCharNum
                End If
            End With
        Next cCmt
    End If
   
    If bExtractHighlights Then
        Set rHighlightRng = dDoc.Range
        rHighlightRng.Find.Highlight = True
        rHighlightRng.Find.Forward = True
        
        Do While rHighlightRng.Find.Execute
            If rHighlightRng.Start = iHighlightPrevStart Then Exit Do
            iHighlightPrevStart = rHighlightRng.Start
            rHighlightRng.Select
           
            iChgCnt = iChgCnt + 1
            StatusBar = "Preparing Highlights, Item " & iChgCnt
            iCharNum = Selection.Start
            iParaNum = wrkGetParaNumSelection
            iChgArray(iChgCnt, 1) = iParaNum
            iChgArray(iChgCnt, 2) = 3
            iChgArray(iChgCnt, 3) = 0
            iChgArray(iChgCnt, 4) = iCharNum
            iChgArray(iChgCnt, 5) = Len(Selection.Range.Text)
        Loop

    End If 'Extract Highlights
    
    iChgArray = wrkBubbleSort(iChgArray, 4, "Ascending", iChgCnt)
End Sub

Sub wrkGetExtractType(sExtractAuthors As String, bExtractComments As Boolean, _
                                            bExtractRevisions As Boolean, bExtractHighlights As Boolean, iHighlightCnt As Integer)
'=================================================================================================
'Determines what type of extract is needed - standard or custom
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Sets a boolen for each type (cmt, rev, highlight) and a list of authors to extect (or All)
'Skips Table of contents changes
'=================================================================================================
    Dim rHighlightRng As Range
    Dim iHighlightPrevStart As Long
    Dim sInputVal As String
    Dim rRev As Revision
    Dim cCmt As Comment
    Dim iCnt As Integer
    Dim sRevAuthors(15) As String  'First 14 authors from 1-15
    Dim iRevCount(15, 2) As Integer '1=Comment Counts, 2= Revison Counts per author
    Dim i As Integer
    Dim iAuthorIndex As Integer 'current author
    Dim iAuthorMaxIndex As Integer ' Number of authors in doc
    Dim sAuthors As String 'String containing the names of the authors to extract
    Dim sAuthorIndex As String 'String showing the authors and comment and revision counts for each
    
    'Application.Sc5reenUpdating = False

    StatusBar = "Preparing revision statistcs"
    
    
    'First count the highlighed sections
    Set rHighlightRng = ActiveDocument.Range
    rHighlightRng.Find.Highlight = True
    rHighlightRng.Find.Forward = True
   
   
    Do While rHighlightRng.Find.Execute
        If rHighlightRng.Start = iHighlightPrevStart Then Exit Do
        iHighlightPrevStart = rHighlightRng.Start
        iHighlightCnt = iHighlightCnt + 1
        iHighlightPrevStart = rHighlightRng.Start
    Loop
    If iHighlightCnt > 0 Then
        bExtractHighlights = True
    Else
        bExtractHighlights = False
    End If
    'Assume otyher types are extected
    bExtractComments = True
    bExtractRevisions = True
    'bExtractHighlights = False
    sExtractAuthors = "ALL"
    
    sInputVal = wrkGetInput("The document contains:" & vbNewLine & vbNewLine & _
                            "     Comments: " & ActiveDocument.Comments.Count & vbNewLine & _
                            "     Revisions   : " & ActiveDocument.Revisions.Count & vbNewLine & _
                            "     Highlights : " & iHighlightCnt & vbNewLine & vbNewLine & _
                            "Perform Standard (full extract) or Custom extract? S/C", "SmartExtract", "S", "S|C", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    'Exit if Standard extract - the attribures are
    If sInputVal = "S" Then Exit Sub
    
    'here if custom extract
    iAuthorMaxIndex = 0
    iCnt = 0
    'Now count the  comments by author
    For Each cCmt In ActiveDocument.Comments
        With cCmt
            iCnt = iCnt + 1
            StatusBar = "Checking Comments. Item " & iCnt
            
            iAuthorIndex = 0
            For i = 1 To UBound(sRevAuthors)
                If sRevAuthors(i) = "" Then Exit For
                If sRevAuthors(i) = .Author Then
                    iAuthorIndex = i
                    Exit For
                End If
            Next i
            If iAuthorIndex = 0 And iAuthorMaxIndex < UBound(sRevAuthors) Then
                iAuthorMaxIndex = iAuthorMaxIndex + 1
                iAuthorIndex = iAuthorMaxIndex
                sRevAuthors(iAuthorIndex) = .Author
            End If
            If iAuthorIndex > 0 Then iRevCount(iAuthorIndex, 1) = iRevCount(iAuthorIndex, 1) + 1
        End With
    Next cCmt
    'Now count the revisions
    ' in some large documents  there may be deleted revisions - unclear why these are there - not seen in the UI
    On Error GoTo SkipDeletedRevisions
    iCnt = 0
    For Each rRev In ActiveDocument.Revisions
        With rRev
            'Only include insertions and deletions
            If .Type = wdRevisionInsert Or .Type = wdRevisionDelete Then
                iCnt = iCnt + 1
                StatusBar = "Checking Revsions. Item " & iCnt
                
                iAuthorIndex = 0
                For i = 1 To UBound(sRevAuthors)
                    If sRevAuthors(i) = "" Then Exit For
                    If sRevAuthors(i) = .Author Then
                        iAuthorIndex = i
                        Exit For
                    End If
                Next i
                If iAuthorIndex = 0 And iAuthorMaxIndex < UBound(sRevAuthors) Then
                    iAuthorMaxIndex = iAuthorMaxIndex + 1
                    iAuthorIndex = iAuthorMaxIndex
                    sRevAuthors(iAuthorIndex) = .Author
                End If
                If iAuthorIndex > 0 Then iRevCount(iAuthorIndex, 2) = iRevCount(iAuthorIndex, 2) + 1
              End If
        End With
    Next rRev
SkipDeletedRevisions:

    'Now build a string to show what authors are in the document
    sAuthors = ""
    For i = 1 To iAuthorMaxIndex
        If i > 1 Then sAuthors = sAuthors & vbNewLine
         sAuthors = sAuthors & " " & i & " " & sRevAuthors(i) & " - Cmts: " & iRevCount(i, 1) & " Revs: " & iRevCount(i, 2)
    Next i
    sExtractAuthors = ""
    sInputVal = wrkGetInput("The following authors are have made revisions: " & vbNewLine & vbNewLine & _
                                sAuthors & vbNewLine & vbNewLine & _
                            "Enter the number of each to extract separated by commas. Leave blank for all.", "SmartExtract", "", "", True)
    
    If sInputVal = "" Then
        sExtractAuthors = "ALL"
    Else
        sInputVal = "," & sInputVal & ","
        sExtractAuthors = "|"
        'Now get the names of the authors whose numbers had been entered
        For i = 1 To iAuthorMaxIndex
            sAuthorIndex = "," & i & ","
            If InStr(sInputVal, sAuthorIndex) > 0 Then
                sExtractAuthors = sExtractAuthors & sRevAuthors(i) & "|"
            End If
        Next i
    End If
    
    'Check if comments are extracted - decided to always ask for these even if there are none
    sInputVal = wrkGetInput("Extract Comments? Y/N", "SmartExtract", "Y", "Y|N", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    If sInputVal = "N" Then bExtractComments = False
    
    sInputVal = wrkGetInput("Extract Revisions? Y/N", "SmartExtract", "Y", "Y|N", True)
    If sInputVal = "" Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    If sInputVal = "N" Then bExtractRevisions = False
    
    'Only offer Highlight counts if there are any
    If bExtractHighlights Then
        sInputVal = wrkGetInput("Extract highlighted sections? Y/N", "SmartExtract", "Y", "Y|N", True)
        If sInputVal = "" Then
            sExtractAuthors = "No Extract"
            Exit Sub
        End If
        If sInputVal = "N" Then bExtractHighlights = False
    End If
    
    If Not bExtractComments And Not bExtractRevisions And Not bExtractHighlights Then
        sExtractAuthors = "No Extract"
        Exit Sub
    End If
    
    Application.ScreenUpdating = True
    
End Sub
    
Function wrkBubbleSort(InputArray As Variant, Optional SortColumn As Integer = 1, _
                          Optional SortOrder As String = "Ascending", _
                          Optional intMaxRows As Integer = 0) As Variant
'=============================================================================================
' Sort a 2-Dimension Array (Credit: Rajan Verma + DocumentProductivity)
' Parameter Info
' InputArray  : Array you want to Sort
' SortColumn  : on Which column you want to sort
' SortOrder   : xlAscending , xlDescending
' intMaxRows  : if >0 will sort only rows 1-MaxRow.  Leaves null rows untouched
'=============================================================================================
    Dim intFirst As Integer
    Dim intLast  As Integer
    Dim intFirstCol As Integer
    Dim intLastCol  As Integer
    Dim sngTemp     As Single
    Dim lngLoop1    As Integer
    Dim i           As Integer
    Dim j           As Integer
    Dim blnFlag     As Boolean
    Dim blnSort     As Boolean
    
    If Not IsArray(InputArray) Then
        blnFlag = True
        GoTo ExitEarly:
    End If
    
    intFirst = LBound(InputArray, 1)
    If intMaxRows > 0 Then
        intLast = intMaxRows
    Else
        intLast = UBound(InputArray, 1)
    End If
    intFirstCol = LBound(InputArray, 2)
    intLastCol = UBound(InputArray, 2)
    StatusBar = "Sorting..."
    For i = intFirst To intLast - 1

        For lngLoop1 = i + 1 To intLast
            If SortOrder = "Ascending" Then
                If InputArray(i, SortColumn) > InputArray(lngLoop1, SortColumn) Then blnSort = True
            Else
                If InputArray(i, SortColumn) < InputArray(lngLoop1, SortColumn) Then blnSort = True
            End If
                If blnSort Then
                    For j = intFirstCol To intLastCol
                        sngTemp = InputArray(lngLoop1, j)
                        InputArray(lngLoop1, j) = InputArray(i, j)
                        InputArray(i, j) = sngTemp
                    Next j
                End If
            blnSort = False
        Next lngLoop1
    Next i
    wrkBubbleSort = InputArray
ExitEarly:
    If blnFlag Then wrkBubbleSort = Null
End Function

'=================================================================================================
'========= Small routines =========================================================================
'=================================================================================================

Sub wrkAcceptAllFormatChanges(sPrompt As String)
'=================================================================================================
'Accepts all format changes in a document
'Release 12 Nov 2015 Martin Coomber documentproductivity.blogspot.co.nz
'Used a standalone routine and also as part of SmartExtract to clean up the extracted text
'================================================================================================
    Dim rRev As Revision
    Dim iCnt As Long
    Dim sInputVal As String
    Dim iRevCnt As Integer
    Dim iRev As Integer
    Dim bAcceptRev As Boolean

    
    If sPrompt = "Prompt" Then
        If ActiveDocument.Revisions.Count = 0 Then
            MsgBox "There are no changes in this document to accept"
            Exit Sub
        Else
            sInputVal = wrkGetInput("Do You want to Accept all Formatting Changes? Y/N", _
                                    "Accept Formatting Changes", "Y", "Y|N", True)
            If sInputVal <> "Y" Then
                Exit Sub
            End If
        End If
    End If ' Propmt
    'here if valid
    'Need to skip deleted revisions that hang around in some large documents
On Error GoTo SkipDeletedRevisions
    iRevCnt = ActiveDocument.Revisions.Count
    For Each rRev In ActiveDocument.Revisions
        iRev = iRev + 1
        StatusBar = "Checking revision " & iRev & " of " & iRevCnt
        bAcceptRev = False
        With rRev
            If Not bAcceptRev And .Range.Paragraphs.Count >= 2 Then ' First parara
                If InStr(.Range.Paragraphs(2).Style, "TOC") > 0 Then bAcceptRev = True
            End If
            If Not bAcceptRev And (.Type = wdRevisionProperty Or _
                                    .Type = wdRevisionTableProperty Or _
                                    .Type = wdRevisionParagraphProperty) Then bAcceptRev = True
            If bAcceptRev Then
                rRev.Accept
                iCnt = iCnt + 1
            End If
        End With
    Next rRev
SkipDeletedRevisions:
     If sPrompt = "Prompt" Then MsgBox iCnt & " Formatting changes were accepted"
 End Sub

'============================================================================
'****************************************************************************
'************************  Smart Bookmark  ********************************
'****************************************************************************
'============================================================================
Sub dpSmartBookmark()
'=================================================================================================
'First use drops a bookmark, second use returns to the initial bookmark
'Release 13 Apr 2016 Martin Coomber documentproductivity.blogspot.co.nz
'If the intitial bookmark isnt returned to after 5 mins, a new return location will be started
'If double pressed, got to top of doc
'Goes to the SmartExtract source location if used in a smart extract cell
'assgined to Ctl+`
'=================================================================================================
    Dim nTimerDiff As Single
        
    'First check if the Goto call is inside a smartextract document. If so, goto the page
    If wrkDocPropExists("dpSmartExtractSource") Then 'Current document was created by SmartExtract,
        'Go to correct page in the source document
        Call wrkGotoSmartExtract
        Exit Sub
    End If
    
    nTimerDiff = Timer - glbSmtBmkLast
    
    If ActiveDocument.Bookmarks.Exists("dpTempGoto") = True Then
        If nTimerDiff > 900 Then 'After 5 mins begin a return location
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            ActiveDocument.Bookmarks.Add Name:="dpTempGoto", Range:=Selection.Range
            StatusBar = "Bookmark Dropped"
            glbSmtBmkLast = Timer
        ElseIf nTimerDiff > 1 Then 'single press with existing bookmark means return
            Selection.GoTo what:=wdGoToBookmark, Name:="dpTempGoto"
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            StatusBar = "Returned to Bookmark"
        Else 'Double press
            ActiveDocument.Bookmarks("dpTempGoto").Delete
            ' Got to TOC or top of document
            If ActiveDocument.TablesOfContents.Count >= 1 Then
                Selection.HomeKey Unit:=wdStory
                Selection.GoTo what:=wdGoToField, Which:=wdGoToNext, Count:=1, Name:="TOC"
                StatusBar = "Moved to Table of Contents"
            Else
                Selection.HomeKey Unit:=wdStory
                StatusBar = "Moved to Beginning"
            End If
        End If
    Else
        ActiveDocument.Bookmarks.Add Name:="dpTempGoto", Range:=Selection.Range
        StatusBar = "Bookmark Dropped"
        glbSmtBmkLast = Timer
    End If

End Sub
Private Sub wrkGotoSmartExtract()
'=================================================================================================
'Goes to the correct page in the source document for SmartExtract
'Release 13 Apr 2016 Martin Coomber documentproductivity.blogspot.co.nz
'Finds the property containing the name of the source
'Source must be open, the tries to find the page number in the current paragraph
'Then goes to source and then to page
'=================================================================================================
    Dim sSrcName As String
    Dim sHeaderText As String
    Dim bDocumentFound As Boolean
    Dim dDoc As Document
    Dim sPageNum As String
    
    sHeaderText = "Comments extracted from:  "
    bDocumentFound = False
    
    'The name of the soruce document is stored in this propert
    If wrkDocPropExists("dpSmartExtractSource") Then
        'get the page number
        If Left(Selection.Range.Paragraphs(1).Range.Text, 5) = "Page " And _
            InStr(Selection.Range.Paragraphs(1).Range.Text, ":") Then
            sPageNum = Mid(Selection.Range.Paragraphs(1).Range.Text, 6, InStr(Selection.Range.Paragraphs(1).Range.Text, ":") - 6)
        End If
        
        'Now check that the document is open
        sSrcName = ActiveDocument.CustomDocumentProperties("dpSmartExtractSource").Value
        For Each dDoc In Documents
            If dDoc.Name = sSrcName Then
                bDocumentFound = True
                Exit For
            End If
        Next dDoc
    End If
    
    'if document is found then go to the relevant page, if not error.
    If bDocumentFound Then
        dDoc.Activate
        If Val(sPageNum) > 0 Then Selection.GoTo what:=wdGoToPage, Which:=wdGoToAbsolute, Count:=Val(sPageNum)
    Else
        MsgBox "The following SmartExtact source is not open." & vbCr & sSrcName, , "SmartExtract"
    End If
End Sub