VBA Tracked Changes HELP

[jafartiyar]

Hi guys,

really need your help here

i'm trying to create a VBA code to pull trakced changes from a document and display it in a newly created document, along with information such as the page and line numbers, author and date of the tracked change.

Does anyone know how i need to change this code so that it picks up ALL changes including formatting changes and comments. This code is only for insertions and deletions but i've tried a few edits and nothing seems to work

Thanks guys


------code-----

Public Sub ExtractTrackedChangesToNewDoc()

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

Title = "Extract Tracked Changes to New Document"
n = 0

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly, Title
GoTo ExitHere
Else

If MsgBox("Do you want to extract tracked changes to a new document?" & vbCr & vbCr & _
"NOTE: Only insertions and deletions will be included. " & _
"All other types of changes will be skipped.", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False

Set oNewDoc = Documents.Add

oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc

.Content = ""

With .PageSetup
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.TopMargin = CentimetersToPoints(2.5)
End With

Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
End With


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")


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


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
.Columns(2).PreferredWidth = 5
.Columns(3).PreferredWidth = 10
.Columns(4).PreferredWidth = 55
.Columns(5).PreferredWidth = 15
.Columns(6).PreferredWidth = 10


End With

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"


End With


For Each oRevision In oDoc.Revisions
Select Case oRevision.Type

Case wdRevisionInsert, wdRevisionDelete

With oRevision

strText = .Range.Text

Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0

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)

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)

oRange.Start = oRange.Start + i
End If
Loop
End With

n = n + 1

Set oRow = oTable.Rows.Add


With oRow

.Cells(1).Range.Text = _
oRevision.Range.Information(wdActiveEndPageNumber)


.Cells(2).Range.Text = _
oRevision.Range.Information(wdFirstCharacterLineNumber)


If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"

oRow.Range.Font.Color = wdColorAutomatic
Else
.Cells(3).Range.Text = "Deleted"

oRow.Range.Font.Color = wdColorRed
End If


.Cells(4).Range.Text = strText


.Cells(5).Range.Text = oRevision.Author


.Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
End With
End Select
Next oRevision


If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly, Title
oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If


With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With

Application.ScreenUpdating = True
Application.ScreenRefresh

oNewDoc.Activate
MsgBox n & " tracked changed have been extracted. " & _
"Finished creating document.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing

End Sub

[fumei]

"Does anyone know how i need to change this code so that it picks up ALL changes including formatting changes and comments. "

Comments are not Track Changes. They are NOT a property of Revisions. They are completely separate from Tracked Changes. In other words, if you turn Track Changes off you can still see inserted Comments.

To get the other Types of revision, simply test for the type. You are already doing this.

BTW: it may be better to use Select Case

A format change - oRevision.FormatDescription (.Type = 3, or wdRevisionProperty) - returns something like:

Formatted: Font: 18 pts

You will have to iterate through the Comments separately.
For Each oRevision In ActiveDocument.Revisions
MsgBox oRevision.Range.Text & vbCrLf & _
oRevision.FormatDescription & vbCrLf & _
oRevision.Type & vbCrLf & _
oRevision.Author
Next
For Each oComment In ActiveDocument.Comments
MsgBox oComment.Range.Text & vbCrLf & _
oComment.Author & vbCrLf & _
oComment.Date
Next
As you can see, Comments and Revisions share a number of the same properties.

[jafartiyar]

Thanks for the quick reply, very much appreciated

I've only been using code for about a month now so i'm not very clear on this. Is there any chance you could show me where i would have to insert this code into mine?

I know im being a little cheeky asking you to do it for me. I'd love to figure it out myself (enjoy the challenge) but have a presentation on this tomorrow and dont want to look a failure (even though it's pretty ridiculous that they expect someone with absolutely no computing background to do this sort of work)

Thanks

[fumei]

You would have to tell what you want exactly. As stated, the Comments are separate. Where do you want to put them?

Where do you want other Revisions types?

I am also a bit confused by:
With oRevision
strText = .Range.Text

Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0

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)
This seems to be the range object oRange to the Revision range. Ok, fair enough, but it seems odd to be looking for a footnotes count. And what are you doing with the Chr(2)?

[fumei]

Something like:
For Each oRevision In oDoc.Revisions
' since all revisions have a new row
Set oRow = oTable.Rows.Add
' and ALL revisions have the same elements in row
With oRow
.Cells(1).Range.Text = _
oRevision.Range.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = _
oRevision.Range.Information(wdFirstCharacterLineNumber)
.Cells(4).Range.Text = strText
.Cells(5).Range.Text = oRevision.Author
.Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
End With
' except for Type in cell 3
Select Case oRevision.Type
Case wdRevisionInsert
oRow.Cells(3).Range.Text = "Inserted"
oRow.Range.Font.Color = wdColorAutomatic
Case wdRevisionDelete
oRow.Cells(3).Range.Text = "Deleted"
oRow.Range.Font.Color = wdColorRed
Case wdRevisionProperty
oRow.Cells(3).Range.Text = "Text: " & oRevision.Range.Text & vbCrLf & _
oRevision.FormatDescription
End Select
Next oRevision
The Case wdRevisionProperty would result in something like:

Text: Whatever
Formatted: Font: 18 pts

As for Comments....change oRevisions to oComment
For Each oComment In oDoc.Comments
' since all revisions have a new row
Set oRow = oTable.Rows.Add
' and ALL revisions have the same elements in row
With oRow
.Cells(1).Range.Text = _
oComment.Range.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = _
oComment.Range.Information(wdFirstCharacterLineNumber)
.Cells(4).Range.Text = strText
.Cells(5).Range.Text = oRevision.Author
.Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
End With
The type is different. So I do not know what you want in your Cells(3). I am not sure if strText is still applicable. If you want, say, the text of the comment, and its Author, and Date...
oComment.Range.Text & vbcrlf & oComment.Author & _
vbcrlf & Format(oComment.Date, "mm-dd-yyyy")
using paragraphs, ending up with something like:

This is a comment
William Shakespeare
10-12-2010

NOTE: it is quite likely that you may have to do some formatting of Author. Here if I make a revisions or comment, Author would return:

gerry.knight

It depends on how things have been set up with Word.

[jafartiyar]

Hi

Sorry it has taken me so long to get back to you.

Ok just to explain further. The original code that i posted does the following...It searches the document for insertions and deletions and then opens a new document, creates a table and lists those insertions and deletions with other information like so...

---------------------------------

|Page| |Line| |Type| |What has been inserted or deleted| |Author| |Date|

|2| |6| |Inserted| |H| |Holbrook, Amanda| |10-13-2010|

3 16 Inserted 1 Baig, Zuhaib 10-14-2010

3 17 Inserted ‘Any untoward medical occurrence' Baig, Zuhaib 10-14-2010

-------------------------------------

This is perfect, it is exactly what i need, but it is not all i need. I would like the macro to also search for a) format changes and b) comments

I would like format changes to look like this:

---------------------------------

Page Line Type What has been inserted or deleted Author Date

2 6 Format 'Individual' - font 6, underlined Holbrook, Amanda 10-13-2010



-------------------------------------

I would like comments to look like this:


---------------------------------
---------------------------------

Page Line Type What has been inserted or deleted Author Date

2 6 Comment'should this really be here?' Holbrook, Amanda 10-13-2010


-------------------------------------

And one last thing that would bre really appreciated is the addition of a 'response' field to the table that is created, where people can type messages regarding the change.

Can somebody please help me with this, preferably by changing the code for me to incorporate these requests? fumei you've been great so far, dont suppose you could help?

I would be eternally grateful

Thanks in advance

[fumei]

Just replace the extraction of Revisions code with extraction of Comments.

I would strongly recommend you break this up into chunks. Separate your new document creation code (and table creation) from your extraction code. That way you can execute your new document code, get the new document with table, and then pass that doc (as a document object) to separate procedures getting revisions, comments, and formats.

Breaking things into task chunks makes writing code - and more importantly DEBUGGING code - much much much easier. And here is an example:
Option Explicit

Public Sub Ask()
' find out if proceeding
Dim oDoc As Document
Dim Title As String

Title = "Extract Tracked Changes to New Document"
Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly, Title
GoTo ExitHere
Else
If MsgBox("Do you want to extract tracked changes to a new document?" & _
vbCr & vbCr & _
"NOTE: Only insertions and deletions will be included. " & _
"All other types of changes will be skipped.", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
Else
Application.ScreenUpdating = False
Call MakeNewDoc(oDoc) ' starts things off
End If
End If
Call FinishUp
Application.ScreenUpdating = True
Application.ScreenRefresh
ExitHere:
End Sub

Public Sub MakeNewDoc(oDoc As Document)
' make the new document with table
Dim oNewDoc As Document
Dim oTable As Table
Dim oCol As Column
Set oNewDoc = Documents.Add

oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
.Content = ""
With .PageSetup
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
.TopMargin = CentimetersToPoints(2.5)
End With
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
End With


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")


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


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
.Columns(2).PreferredWidth = 5
.Columns(3).PreferredWidth = 10
.Columns(4).PreferredWidth = 55
.Columns(5).PreferredWidth = 15
.Columns(6).PreferredWidth = 10
End With

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"
End With
Call ExtractRevisionsToNewDoc(oDoc, oNewDoc)
End Sub



Public Sub ExtractRevisionsToNewDoc(oDoc As Document, _
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
Set oTable = oNewDoc.Tables(1)

For Each oRevision In oDoc.Revisions
Select Case oRevision.Type
Case wdRevisionInsert, wdRevisionDelete
With oRevision
strText = .Range.Text
Set oRange = .Range
Do While InStr(1, oRange.Text, Chr(2)) > 0
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)
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)
oRange.Start = oRange.Start + i
End If
Loop
End With

n = n + 1

Set oRow = oTable.Rows.Add
With oRow
.Cells(1).Range.Text = _
oRevision.Range.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = _
oRevision.Range.Information(wdFirstCharacterLineNumber)


If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
oRow.Range.Font.Color = wdColorAutomatic
Else
.Cells(3).Range.Text = "Deleted"
oRow.Range.Font.Color = wdColorRed
End If
.Cells(4).Range.Text = strText
.Cells(5).Range.Text = oRevision.Author
.Cells(6).Range.Text = Format(oRevision.Date, "mm-dd-yyyy")
End With
End Select
Next oRevision

With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With
Call ExtractComments(oDoc, oNewDoc)
End Sub

Public Sub ExtractComments(oDoc As Document, oNewDoc As Document)
Dim oComment As Comment
Dim oTable As Table
Dim oRow As Row
Dim oCol As Column
Dim oRange As Range
Set oTable = oNewDoc.Tables(1)
For Each oComment In oDoc.Comments
Set oRow = oTable.Rows.Add
With oRow
.Cells(1).Range.Text = _
oComment.Range.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = _
oComment.Range.Information(wdFirstCharacterLineNumber)
.Cells(4).Range.Text = oComment.Range.Text
.Cells(5).Range.Text = oComment.Author
.Cells(6).Range.Text = Format(oComment.Date, "mm-dd-yyyy")
End With
Next
'Call ExtractFormats(oDoc, oNewDoc) - not written here
End Sub

Public Sub FinishUp(oNewDoc As Document)
oNewDoc.Activate
MsgBox n & " tracked changed have been extracted. " & _
"Finished creating document.", vbOKOnly, Title
Set oDoc = Nothing
Set oNewDoc = Nothing

End Sub


BTW, this is assuming - and you do not state (you are not good at answering questions) - all this stuff is going into the same table. I still do not know what you are doing with the footnote issue.

If you execute this, you DO end up with the revisions, and the Comments goin ginto the table. I did not write the formatting code for you...YOU do it.

However...you will see that the Comments will have -1 as the Page and Line numbers. That is because they do not have any.

Thus, you can go to ONLY the procedure dealing with Comments, and debug it. You do not have to wade through all the other stuff (that is working). The problem is in the Comments code..and if the Comment code is in its own procedure (chunk) THAT is where you go to fix things.

Like remove the instruction to get the Page and Line number.

As for the Formatting chunk (procedure) you should be able to write it from the previous posts.

[martin@dprod]

Hi - You might be interested in a routine I've recently published which does what you asked for, plus more.
It presents the revisions and comments in one table, in the order that they appear in the document so you get to see the comments and changes for each paragraph together.
I have expanded the context of the comment or change to include the entire paragraph or table cell where it was made. This means you get better information to interpret the change.
By including a wider context, I can show the insertion and strike through deletions in a different color as you see the in track changes view.
I've added page, line and table references and included a tool to quickly jump from the summary table to the relevant page in the source document.
The enhanced table allows me to respond point-by-point to reviewer's changes and questions, and it is also a great resource for review meetings.

It is available for free download for free at DocumentProductivity at blogspot.com. See the release notes for the code or download the other productivity tools there too.
Martin
DocumentProductivity