Public Sub Extract_Tracked_Changes() '=========================
'Macro Edited by Jeffrey N. Mahoney 2014 - Added more fields for the type of edit
'Added the ability to open many documents and process them all at once.
'Added a statusbar update
'Added text moved to and from location
'Added more columns to suit particular needs
'MAKE SURE YOU SAVE CHANGES TO DOCUMENTS BEFORE PRECEDING
'+++++++++++++++++++++++++
'
'Original Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro processes all open documents with track changes
'It creates a new document with the same name as the original but with "_Track" at the end
'it extracts insertions and deletions
'marked as tracked changes from the active document
'NOTE: Other types of changes are skipped
'(e.g. formatting changes or inserted/deleted footnotes and endnotes)
'Only insertions and deletions in the main body of the document will be extracted
'The document will also include metadata
'Inserted text will be applied black font color
'Deleted text will be applied red font color
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim oCol As Column
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim n As Long
Dim i As Long
Dim Title As String
Dim RCnt As Long
Dim cPage As Long
Dim cLine As Long
Dim cType As Long
Dim RowNum As Long
Dim A As String
Dim X As Long
Dim TotFileCnt As Long
Dim ThisDocStr As String
Dim FileCnt As Long 'Count
Dim CurDocStr As String
Title = "Extract Tracked Changes to New Documents"
ThisDocStr = ActiveDocument.Name
FileCnt = 0
'Count all the documents except this macro
For Each oDoc In Documents
CurDocStr = oDoc.Name
If CurDocStr <> ThisDocStr Then
TotFileCnt = TotFileCnt + 1
End If
Next oDoc
'check to see if no other files exist
If TotFileCnt < 1 Then
If MsgBox("All " & Str$(TotFileCnt) & " Open Documents will have tracked changes extracted to new files" & vbCr & _
"The following types of track changes will be included in this report: Insertions, Deletions, Replaced, and Moved" & vbCr & vbCr & _
"Do you want to continue?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
Else
MsgBox "No open documents found. Please open documents with track changes before running the macro"
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
For Each oDoc In Documents
CurDocStr = oDoc.Name
FileCnt = FileCnt + 1
If CurDocStr = ThisDocStr Then GoTo NextFile
'check to see if there are any revisions
RCnt = oDoc.Revisions.Count
If RCnt = 0 Then
oDoc.Close (False)
GoTo NextFile
End If
'reset statusbar variables
n = 0
RowNum = 0
'Create a new document for the tracked changes
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
'Make sure any content is deleted
.Content = ""
'Set appropriate margins
With .PageSetup
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.TopMargin = CentimetersToPoints(2.5)
End With
'Insert a 9-column table for the tracked changes and metadata
Set oTable = .Tables.Add(Range:=Selection.Range, numrows:=1, NumColumns:=9)
End With
'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Tracked changes extracted from: " & oDoc.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
With .Font
.Name = "Arial"
.Size = 9
.Bold = False
End With
With .ParagraphFormat
.LeftIndent = 0
.SpaceAfter = 6
End With
End With
With oNewDoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format the table appropriately
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
For Each oCol In .Columns
oCol.PreferredWidthType = wdPreferredWidthPercent
Next oCol
.Columns(1).PreferredWidth = 5 'Page
.Columns(2).PreferredWidth = 5 'Line
.Columns(3).PreferredWidth = 10 'Type of change
.Columns(4).PreferredWidth = 30 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
.Columns(7).PreferredWidth = 5 'IPR Yes
.Columns(8).PreferredWidth = 5 'IPR No
.Columns(9).PreferredWidth = 15 'IPR No w/Guidance
End With
'Insert table headings
With oTable.Rows(1)
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Line"
.Cells(3).Range.Text = "Type"
.Cells(4).Range.Text = "What has been inserted or deleted"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
.Cells(7).Range.Text = "IPR Yes"
.Cells(8).Range.Text = "IPR No"
.Cells(9).Range.Text = "IPR No w/Guidance"
End With
With oTable.Rows(1)
.Cells.VerticalAlignment = wdCellAlignVerticalBottom
End With
'Get info from each tracked change (insertion/deletion) from oDoc and insert in table
For Each oRevision In oDoc.Revisions
Select Case oRevision.Type
'Only include insertions and deletions
Case wdRevisionInsert, wdRevisionDelete, wdRevisionReplace, wdRevisionMovedFrom, wdRevisionMovedTo
'In case of footnote/endnote references (appear as Chr(2)),
'insert "[footnote reference]"/"[endnote reference]"
With oRevision
'Get the changed text
strText = .Range.Text
Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0
'Find each Chr(2) in strText and replace by appropriate text
i = InStr(1, strText, Chr(2))
If oRange.Footnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[footnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i
ElseIf oRange.Endnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[endnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i
End If
Loop
End With
'Add 1 to counter
n = n + 1
'Add row to table
Set oRow = oTable.Rows.Add
'Insert data in cells in oRow
With oRow
cPage = Val(oRevision.Range.Information(wdActiveEndPageNumber))
cLine = Val(oRevision.Range.Information(wdFirstCharacterLineNumber))
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'Page number
.Cells(1).Range.Text = oRevision.Range.Information(wdActiveEndPageNumber)
'Line number - start of revision
.Cells(2).Range.Text = oRevision.Range.Information(wdFirstCharacterLineNumber)
'Type of revision
cType = oRevision.Type
Select Case cType
Case wdRevisionInsert
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
Case wdRevisionDelete
.Cells(3).Range.Text = "Deleted"
'Apply red color
oRow.Range.Font.Color = wdColorRed
Case wdRevisionReplace
.Cells(3).Range.Text = "Replaced"
'Apply red color
oRow.Range.Font.Color = wdColorRed
Case wdRevisionMovedFrom
.Cells(3).Range.Text = "Moved From"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
Case wdRevisionMovedTo
.Cells(3).Range.Text = "Moved To"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
End If
'The inserted/deleted text
.Cells(4).Range.Text = strText
'The author
.Cells(5).Range.Text = oRevision.Author
'The revision date
.Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
End With
End Select
'update statusbar every tenth revision
If n - RowNum >= 10 Then
Application.StatusBar = "File:" & Str$(TotFileCnt + 1 - FileCnt) & " Revision:" & Str$(n)
RowNum = n
End If
Next oRevision
'Apply bold formatting and heading format to row 1
With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With
'Get the original filename and path. Add "_Track" to end
A = CurDocStr
For X = Len(A) To 1 Step -1
If Mid$(A, X, 1) = "." Then
A = Left$(A, X - 1) & "_Track"
Exit For
End If
Next X
A = oDoc.Path & "\" & A
oNewDoc.SaveAs2 (A)
oNewDoc.Close
oDoc.Close
NextFile:
Next oDoc
If FileCnt < 1 Then
MsgBox "There are no other documents open. Please open a document with track changes."
Exit Sub
End If
Application.ScreenUpdating = True
Application.ScreenRefresh
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
Application.StatusBar = ""
End Sub
