Track Changes VBA Granular information needed

[Krumrei]

I have a VBA code that allows me to extract and create a new document and
formatted report of the track changes that happened to the document.

However, I need it to be more specific in what changes.

Sorry for the clarification issue.


1. I need to know what fields ( wdrevisionproperty etc etc. ) I can use to
extract more specific changes.

2. I have a macro built that pulls all document changes, but they only
include Insert and Deletes and Table Cell property changes, and then extracts
them into a new document.

3. I need to dig deeper such as knowing if the change in the document was a
Bold, Italic, Underline or Font or style change, I have 13 different changes
within the document that I want to have on a report, to identify what changes
happened on the document.

Again, I really need to know which VBA wd code I need to use to extract a
more granular piece of what changed, not the high level, insert and delete in
my Macro.

The review pane of the track changes document, outlines more granular
changes in the document, such as Format Font Bold changes, but again, I am
not sure which wd code I need to use to extract that into a report with my
Macro.




Thanks!

 

[Jay Freedman]

This description isn't much more informative than the previous one you
posted, but let's start trying to pull out the necessary information.

The Document object has a .Revisions member, which returns a collection of
Revision objects. Each Revision object has a .Type property that has a data
type of WdRevisionType. If you open the VBA Help topic about the .Type
property as it applies to the Revision object, and expand the WdRevisionType
link there, you'll see this table:

WdRevisionType can be one of these WdRevisionType constants.
wdNoRevision
wdRevisionDelete
wdRevisionInsert
wdRevisionParagraphProperty
wdRevisionReconcile
wdRevisionSectionProperty
wdRevisionStyleDefinition
wdRevisionConflict
wdRevisionDisplayField
wdRevisionParagraphNumber
wdRevisionProperty
wdRevisionReplace
wdRevisionStyle
wdRevisionTableProperty


In addition, each Revision object has a .FormatDescription property; the
Help topic for that property says "Returns a String representing a
description of tracked formatting changes in a revision." That topic has an
example of code that, besides showing how to display the string, also
demonstrates the usual kind of loop for stepping through the entire
Revisions collection. You'll have to experiment with various kinds of format
changes to see what the strings look like, and then you can set up a Select
Case to look for specific strings.

Each Revision object has a .Range property, and the expression .Range.Text
will extract the text of the revision. There is also a .Date property and a
..Author property to tell you when the revision was made and by whom.

That's the background of what Word gives you to work with -- the information
that's available for each revision to determine what kind it is and what
formatting, if any, is involved.. The details of how you want to structure
and format your report document are up to you.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

 

[Krumrei]

Here is the code I wrote for it.

ublic Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly,
Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes will be
included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or format
changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion, wdRevisionCellInsertion,
wdCommentsStory, wdRevisedPropertiesMarkBold, wdRevisionsViewFinal
'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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type = wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion Then
.Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevisionType = wdRevisionsViewFinal Then
.Cells(3).Range.Text = "Bold"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue




Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close oNewDoc
If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly, Title
oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.", vbOKOnly,
Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing

End Sub

 

[Jay Freedman]

OK, now I can see where you went astray.

In the Select Case oRevision.Type structure, the first Case statement is

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal

But the constant wdRevisedPropertiesMarkBold is not a possible value of the
..Type (instead, it's a member of the WdRevisedPropertiesMark enumeration,
used to specify what kind of formatting to apply to changes, e.g., bold or
italic). The value that should be there instead is wdRevisionProperty, which
is the value of the .Type for a revision that involves only formatting.

Then, in the series of If...ElseIf... statements that check the various
..Type values, you need a clause for the wdRevisionProperty value, and inside
the clause you need to look at oRevision.FormatDescription. That will be a
string with a value such as "Formatted: Font: Italic" or "Formatted: List
Paragraph, Bulleted + Level: 1 + Aligned at: 0.25" + Indent at: 0.5"". You
can use the InStr function to look for specific words such as "Italic"
within the string, or you can just dump out the whole string into column 3
of the report table.

While you're cleaning up the Select Case, note that wdCommentsStory and
wdRevisionsViewFinal also are not possible values of the .Type property, so
you can remove them, too.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

Here is the code I wrote for it.

ublic Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal '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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevisionType = wdRevisionsViewFinal Then
.Cells(3).Range.Text = "Bold"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue




Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly,
Title oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.",
vbOKOnly, Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing

End Sub

I have a VBA code that allows me to extract and create a new
document and formatted report of the track changes that happened to
the document.

However, I need it to be more specific in what changes.

Sorry for the clarification issue.


1. I need to know what fields ( wdrevisionproperty etc etc. ) I can
use to extract more specific changes.

2. I have a macro built that pulls all document changes, but they
only include Insert and Deletes and Table Cell property changes, and
then extracts them into a new document.

3. I need to dig deeper such as knowing if the change in the
document was a Bold, Italic, Underline or Font or style change, I
have 13 different changes within the document that I want to have on
a report, to identify what changes happened on the document.

Again, I really need to know which VBA wd code I need to use to
extract a more granular piece of what changed, not the high level,
insert and delete in my Macro.

The review pane of the track changes document, outlines more granular
changes in the document, such as Format Font Bold changes, but
again, I am not sure which wd code I need to use to extract that
into a report with my Macro.




Thanks!

 

[Krumrei]

Could you get me started on the code? You sorta lost me a bit?

If you can tell me where and what I need to add, I can figure out the rest
of it.

Thank you sir!

Paul

OK, now I can see where you went astray.

In the Select Case oRevision.Type structure, the first Case statement is

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal

But the constant wdRevisedPropertiesMarkBold is not a possible value of the
..Type (instead, it's a member of the WdRevisedPropertiesMark enumeration,
used to specify what kind of formatting to apply to changes, e.g., bold or
italic). The value that should be there instead is wdRevisionProperty, which
is the value of the .Type for a revision that involves only formatting.

Then, in the series of If...ElseIf... statements that check the various
..Type values, you need a clause for the wdRevisionProperty value, and inside
the clause you need to look at oRevision.FormatDescription. That will be a
string with a value such as "Formatted: Font: Italic" or "Formatted: List
Paragraph, Bulleted + Level: 1 + Aligned at: 0.25" + Indent at: 0.5"". You
can use the InStr function to look for specific words such as "Italic"
within the string, or you can just dump out the whole string into column 3
of the report table.

While you're cleaning up the Select Case, note that wdCommentsStory and
wdRevisionsViewFinal also are not possible values of the .Type property, so
you can remove them, too.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

Here is the code I wrote for it.

ublic Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal '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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevisionType = wdRevisionsViewFinal Then
.Cells(3).Range.Text = "Bold"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue




Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly,
Title oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.",

 

[Jay Freedman]

Step 1: Modify the Case statement to

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdRevisionProperty

That gets rid of the values that don't belong there, and adds the
wdRevisionProperty value that you need.

Step 2: Look at the part of your code that has

'Type of revision
If oRevision.Type = wdRevisionInsert Then
' a bunch of stuff
ElseIf oRevision.Type = wdRevisionDelete Then

' a bunch of other stuff
' and then more ElseIf statements for other .Type values
Else
' it's some other revision -- do nothing
End If

You need to put in (before the Else statement) something like this:

ElseIf oRevision.Type = wdRevisionProperty Then
.Cells(3).Range.Text = oRevision.FormatDescription
oRow.Range.Font.Color = wdColorBlue

Of course, it's your choice whether to use blue font color or something
else, and whether you want to write the entire format description string
into the table cell.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

Could you get me started on the code? You sorta lost me a bit?

If you can tell me where and what I need to add, I can figure out the
rest of it.

Thank you sir!

Paul

OK, now I can see where you went astray.

In the Select Case oRevision.Type structure, the first Case
statement is

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal

But the constant wdRevisedPropertiesMarkBold is not a possible value
of the ..Type (instead, it's a member of the WdRevisedPropertiesMark
enumeration, used to specify what kind of formatting to apply to
changes, e.g., bold or italic). The value that should be there
instead is wdRevisionProperty, which is the value of the .Type for a
revision that involves only formatting.

Then, in the series of If...ElseIf... statements that check the
various ..Type values, you need a clause for the wdRevisionProperty
value, and inside the clause you need to look at
oRevision.FormatDescription. That will be a string with a value such
as "Formatted: Font: Italic" or "Formatted: List Paragraph, Bulleted
+ Level: 1 + Aligned at: 0.25" + Indent at: 0.5"". You can use the
InStr function to look for specific words such as "Italic" within
the string, or you can just dump out the whole string into column 3
of the report table.

While you're cleaning up the Select Case, note that wdCommentsStory
and wdRevisionsViewFinal also are not possible values of the .Type
property, so you can remove them, too.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the
newsgroup so all may benefit.

Here is the code I wrote for it.

ublic Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes
Then GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on
Normal.dot 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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal '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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell
Delete" 'Apply automatic color (black on
white) oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevisionType = wdRevisionsViewFinal Then
.Cells(3).Range.Text = "Bold"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue




Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly,
Title oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.",

 

[Krumrei]

You are the man!

Will the .oRevision.FormatDescription List out what it is e.g. Italic?
etc. etc or do I have to define that with a "description goes here between
quotes"?


Thank you so much sir this is really helping me out!

Step 1: Modify the Case statement to

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdRevisionProperty

That gets rid of the values that don't belong there, and adds the
wdRevisionProperty value that you need.

Step 2: Look at the part of your code that has

'Type of revision
If oRevision.Type = wdRevisionInsert Then
' a bunch of stuff
ElseIf oRevision.Type = wdRevisionDelete Then

' a bunch of other stuff
' and then more ElseIf statements for other .Type values
Else
' it's some other revision -- do nothing
End If

You need to put in (before the Else statement) something like this:

ElseIf oRevision.Type = wdRevisionProperty Then
.Cells(3).Range.Text = oRevision.FormatDescription
oRow.Range.Font.Color = wdColorBlue

Of course, it's your choice whether to use blue font color or something
else, and whether you want to write the entire format description string
into the table cell.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

Could you get me started on the code? You sorta lost me a bit?

If you can tell me where and what I need to add, I can figure out the
rest of it.

Thank you sir!

Paul

OK, now I can see where you went astray.

In the Select Case oRevision.Type structure, the first Case
statement is

Case wdRevisionInsert, wdRevisionDelete,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal

But the constant wdRevisedPropertiesMarkBold is not a possible value
of the ..Type (instead, it's a member of the WdRevisedPropertiesMark
enumeration, used to specify what kind of formatting to apply to
changes, e.g., bold or italic). The value that should be there
instead is wdRevisionProperty, which is the value of the .Type for a
revision that involves only formatting.

Then, in the series of If...ElseIf... statements that check the
various ..Type values, you need a clause for the wdRevisionProperty
value, and inside the clause you need to look at
oRevision.FormatDescription. That will be a string with a value such
as "Formatted: Font: Italic" or "Formatted: List Paragraph, Bulleted
+ Level: 1 + Aligned at: 0.25" + Indent at: 0.5"". You can use the
InStr function to look for specific words such as "Italic" within
the string, or you can just dump out the whole string into column 3
of the report table.

While you're cleaning up the Select Case, note that wdCommentsStory
and wdRevisionsViewFinal also are not possible values of the .Type
property, so you can remove them, too.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the
newsgroup so all may benefit.

Krumrei wrote:
Here is the code I wrote for it.

ublic Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes
Then GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on
Normal.dot 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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdCommentsStory,
wdRevisedPropertiesMarkBold, wdRevisionsViewFinal '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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell
Delete" 'Apply automatic color (black on

 

[Jay Freedman]

You are the man!

Will the .oRevision.FormatDescription List out what it is e.g.
Italic? etc. etc or do I have to define that with a "description goes
here between quotes"?


Thank you so much sir this is really helping me out!

As I wrote a couple of messages back in the thread,

....you need to look at oRevision.FormatDescription. That will be a
string with a value such as "Formatted: Font: Italic" or "Formatted: List
Paragraph, Bulleted + Level: 1 + Aligned at: 0.25" + Indent at: 0.5"".

So the text that appears in your table will be the description of the
formatting change. You don't need to add anything to it. After you run the
modified macro on a few documents, you may decide you want to change some of
the descriptions -- if so, post back and we'll discuss how to do that.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

 

[Krumrei]

Thanks!!!! It works great!

As I wrote a couple of messages back in the thread,

....you need to look at oRevision.FormatDescription. That will be a
string with a value such as "Formatted: Font: Italic" or "Formatted: List
Paragraph, Bulleted + Level: 1 + Aligned at: 0.25" + Indent at: 0.5"".

So the text that appears in your table will be the description of the
formatting change. You don't need to add anything to it. After you run the
modified macro on a few documents, you may decide you want to change some of
the descriptions -- if so, post back and we'll discuss how to do that.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

 

[Krumrei]

Ok, now that it works, how can I determine the Deleted items were Grammar,
punctuation, etc. etc if possible?

And also, you were going to show me about the information on how to pull
more thatn what you gave me?


Thanks Jay!

 

[Krumrei]

Jay,

Lets say I do want to use the InStr function to extract specific titles in
the revisions properties, such as Italic, bold, etc. etc how to I put that in
my code listed?

Thanks!

 

[Jay Freedman]

We're back to the point where I need to know what you plan to do with the
results before I can suggest specific code. What follows is more general, in the
hope that you can learn to develop the specifics for yourself.

The InStr function takes at least two strings (there could be more arguments,
but let's start simple). If the second string occurs somewhere in the first
string, then the function returns the position of the first matching character
from the start of the first string; otherwise it returns zero. For example,
InStr("abcd", "bc") returns the value 2, while Instr("abcd", "cb") returns 0
because "cb" doesn't occur in "abcd".

Another bit you need to know is that the comparison in InStr is case-sensitive;
that is, "Bc" would not be found in "abcd" because the case of the "B" is
different. When you want to do a comparison that ignores case, convert both
strings to lower case with the LCase() function.

One other thing is that any one .FormatDescription string can contain two,
three, or more separate formatting items. For example, one could be "Font: 12pt,
Bold, Italic". If you're keeping separate track of bold formatting and italic
formatting, you need to test the .FormatDescription string separately for each
item.

So here's a small example; you would replace the MsgBox statements with whatever
it is you want to do with the information about formatting:

Dim oRev As Revision
For Each oRev In ActiveDocument.Revisions
If oRev.Type = wdRevisionProperty Then
If InStr(LCase(oRev.FormatDescription), "bold") > 0 Then
MsgBox "bold included"
End If
If InStr(LCase(oRev.FormatDescription), "italic") > 0 Then
MsgBox "italic included"
End If
If InStr(LCase(oRev.FormatDescription), "font color") > 0 Then
MsgBox "font color included"
End If
End If
Next

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so all
may benefit.

 

[Krumrei]

IT blows up on me where I insterted your code.


Public Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.", vbOKOnly,
Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes will be
included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or format
changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion, wdRevisionCellInsertion,
wdRevisionProperty
'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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type = wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion Then
.Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue


ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold") Then
End If
If InStr(LCase(oRev.FormatDescription), "italic") > 0 Then
End If
If InStr(LCase(oRev.FormatDescription), "font color") > 0
Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close oNewDoc
If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly, Title
oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.", vbOKOnly,
Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing

End Sub

 

[Jay Freedman]

OK, there are several things going on here.

First, please don't post something like "it blows up on me" without any
other description. If you get an error message, quote the message _exactly_.
If a particular line of code is highlighted, indicate which line that is.
Otherwise, we're left poking around in your code to guess what might be
going on, which is a waste of our time and yours.

Next, after poking around and guessing, I gather that you're getting a
compiler error, and the cause is that you have an If statement without a
matching End If statement. It's in this new section of the code:

ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold") Then
End If
If InStr(LCase(oRev.FormatDescription), "italic") > 0 Then
End If
If InStr(LCase(oRev.FormatDescription), "font color") > 0
Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
End If

The If statement that looks for "font color" doesn't have a matching End If.
So VBA assumes that the Else and End If statements after the gap belong to
that If, which leaves the first If oRevision.Type statement without any
possible match. At that point the compiler gives up and displays an error.
If you stick an End If statement into the gap, the error won't appear.

Lastly, your If...End If groups for "bold" and "italic" don't have any
content, so they won't do anything. I assume that's because you haven't
finished yet.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

IT blows up on me where I insterted your code.


Public Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdRevisionProperty
'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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue


ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold")
Then End If
If InStr(LCase(oRev.FormatDescription), "italic") >
0 Then End If
If InStr(LCase(oRev.FormatDescription), "font
color") > 0 Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then
MsgBox "No insertions or deletions were found.", vbOKOnly,
Title oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
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. " & _
"Black = Inserted, Red = Deleted, Blue = Format Changes.",
vbOKOnly, Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing

End Sub

 

[Krumrei]

Sorry about that, I was not thinking about highlighting the areas and I will
be more specific in my replies.

I will try this again and let you know.

Thank you again!

Paul

OK, there are several things going on here.

First, please don't post something like "it blows up on me" without any
other description. If you get an error message, quote the message _exactly_.
If a particular line of code is highlighted, indicate which line that is.
Otherwise, we're left poking around in your code to guess what might be
going on, which is a waste of our time and yours.

Next, after poking around and guessing, I gather that you're getting a
compiler error, and the cause is that you have an If statement without a
matching End If statement. It's in this new section of the code:

ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold") Then
End If
If InStr(LCase(oRev.FormatDescription), "italic") > 0 Then
End If
If InStr(LCase(oRev.FormatDescription), "font color") > 0
Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
End If

The If statement that looks for "font color" doesn't have a matching End If.
So VBA assumes that the Else and End If statements after the gap belong to
that If, which leaves the first If oRevision.Type statement without any
possible match. At that point the compiler gives up and displays an error.
If you stick an End If statement into the gap, the error won't appear.

Lastly, your If...End If groups for "bold" and "italic" don't have any
content, so they won't do anything. I assume that's because you haven't
finished yet.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

IT blows up on me where I insterted your code.


Public Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdRevisionProperty
'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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue


ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold")
Then End If
If InStr(LCase(oRev.FormatDescription), "italic") >
0 Then End If
If InStr(LCase(oRev.FormatDescription), "font
color") > 0 Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then

 

[Krumrei]

Is there a way to get that Instr string to determine what has been Deleted?

Say for instance, Track Changes marks a Grammar or Spelling Error as a delete.

Can I use this to determine if thoat Deleted items was an actual delete or
if it was marked as deleted due to a spelling or grammar issue?



Thanks!

OK, there are several things going on here.

First, please don't post something like "it blows up on me" without any
other description. If you get an error message, quote the message _exactly_.
If a particular line of code is highlighted, indicate which line that is.
Otherwise, we're left poking around in your code to guess what might be
going on, which is a waste of our time and yours.

Next, after poking around and guessing, I gather that you're getting a
compiler error, and the cause is that you have an If statement without a
matching End If statement. It's in this new section of the code:

ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold") Then
End If
If InStr(LCase(oRev.FormatDescription), "italic") > 0 Then
End If
If InStr(LCase(oRev.FormatDescription), "font color") > 0
Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
End If

The If statement that looks for "font color" doesn't have a matching End If.
So VBA assumes that the Else and End If statements after the gap belong to
that If, which leaves the first If oRevision.Type statement without any
possible match. At that point the compiler gives up and displays an error.
If you stick an End If statement into the gap, the error won't appear.

Lastly, your If...End If groups for "bold" and "italic" don't have any
content, so they won't do anything. I assume that's because you haven't
finished yet.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

IT blows up on me where I insterted your code.


Public Sub ExtractTrackedChangesToNewDoc()

'Macro created 2008 by Paul Krumrei
'The macro creates a new document
'and 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

Title = "Extract Tracked Changes to New Document"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "The active document contains no tracked changes.",
vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Do you want to extract tracked changes to a new
document?" & vbCr & vbCr & _
"NOTE: Only Insertions,Deletions and Format Changes
will be included. ", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If

Application.ScreenUpdating = False
'Create a new document for the tracked changes, base on Normal.dot
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 6-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=6)
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 = 55 'Inserted/deleted text
.Columns(5).PreferredWidth = 15 'Author
.Columns(6).PreferredWidth = 10 'Revision date
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 or
format changed"
.Cells(5).Range.Text = "Author"
.Cells(6).Range.Text = "Date"
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,
wdRevisionTableProperty, wdRevisionCellDeletion,
wdRevisionCellInsertion, wdRevisionProperty
'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
'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
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
' do something for inserts
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorRed
' do something for deletes



ElseIf oRevision.Type =
wdRevisionTableProperty Then
.Cells(3).Range.Text = "Table" 'Apply
automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdRevisionCellDeletion
Then .Cells(3).Range.Text = "Table Cell Delete"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type =
wdRevisionCellInsertion Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue

ElseIf oRevision.Type = wdCommentsStory Then
.Cells(3).Range.Text = "Table Cell Insert"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorBlue


ElseIf oRevision.Type = wdRevisionProperty Then
If InStr(LCase(oRevision.FormatDescription), "bold")
Then End If
If InStr(LCase(oRev.FormatDescription), "italic") >
0 Then End If
If InStr(LCase(oRev.FormatDescription), "font
color") > 0 Then
.Cells(3).Range.Text = ""
oRow.Range.Font.Color = wdColorBlue



Else
' it's some other revision -- do nothing
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
Next oRevision

'If no insertions/deletions were found, show message and close
oNewDoc If n = 0 Then

 

[Jay Freedman]

Is there a way to get that Instr string to determine what has been
Deleted?

Say for instance, Track Changes marks a Grammar or Spelling Error as
a delete.

Can I use this to determine if thoat Deleted items was an actual
delete or
if it was marked as deleted due to a spelling or grammar issue?



Thanks!

It doesn't appear that the Revision object contains any information of that
sort. A deletion is a deletion, period.

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so
all may benefit.

 

[Krumrei]

Ok, one final part of this.

Since Track Changes creates a Delete Bubble on the document, and it pulls
the Delete information of what was deleted, how can I pull say, if I deleted
a punctuation such as a perido, comma, quotes etc etc into my statement
instead of just the phrase Delete?

I would like it to say "Deleted Comma" if it recognized that the
orevision.text was deleted, but was a "," and so forth.

Make sense?

 

[Jay Freedman]

What you see in the bubble following the "Deleted:" label is just the
..Range.Text property of that Revision. To check whether that is just a
punctuation character, you can do something like this:

Dim oRevision As Revision
For Each oRevision In ActiveDocument.Revisions
With oRevision
If .Type = wdRevisionDelete Then
If .Range.Text = "," Then
MsgBox "Deleted Comma"
ElseIf .Range.Text = "." Then
MsgBox "Deleted Period"
ElseIf .Range.Text = ":" Then
MsgBox "Deleted Colon"
End If
End If
End With
Next

Again, replace the MsgBox statements with statements to put that text into the
proper table cell.

Add more ElseIf clauses for any other punctuation you want to catch. Any
characters that don't have an ElseIf (or if the deleted text was more than just
one character) will show up in the table column that contains .Range.Text.

 

[Krumrei]

When I added this, the Cells are not being populated with the "" information.

ElseIf oRevision.Type = wdRevisionDelete Then
If .Range.Text = "," Then
..Cells(3).Range.Text = "Comma Deleted"
ElseIf .Range.Text = "." Then
..Cells(3).Range.Text = "Period Deleted"
ElseIf .Range.Text = ":" Then
..Cells(3).Range.Text = "Semi Colon Deleted"