Scribd
Upload
11 views

Extract Tracked Changes To New Doc

vba ExtractTrackedChangesToNewDoc

Uploaded by

useless438rubbish
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
11 views

Extract Tracked Changes To New Doc

vba ExtractTrackedChangesToNewDoc

Uploaded by

useless438rubbish
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 4

Public Sub ExtractTrackedChangesToNewDoc()

'=========================
'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP
THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'Adopted for use by Desmund Hui, 2018
'=========================
'The macro creates a new document
'and extracts insertions and deletions
'marked as tracked changes from the active document
'The document will also include metadata
'Inserted text will be applied automatic (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?", _
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 if necessary
'oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
'Make sure any content is deleted
.Content = ""
'Set appropriate margins
With .PageSetup
.PaperSize = wdPaperA4
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.TopMargin = CentimetersToPoints(1)
End With
'Insert a 5-column table for the tracked changes and metadata
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=1, _
NumColumns:=5)
End With

'Insert info in header - change date format as you wish


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")
'Footer: page number
.Footers(wdHeaderFooterPrimary).PageNumbers.Add _
PageNumberAlignment:=wdAlignPageNumberRight, _
FirstPage:=True
End With

'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 = 6.5 'Page
.Columns(2).PreferredWidth = 6.5 'Line
.Columns(3).PreferredWidth = 12 'Type of change
.Columns(4).PreferredWidth = 27 'Section
.Columns(5).PreferredWidth = 48 'Changed text
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 = "Section"
.Cells(5).Range.Text = "Where the changes are applied to"
End With

'Get info from each tracked change from oDoc and insert in table
For Each oRevision In oDoc.Revisions
Select Case oRevision.Type
'Only include insertions, deletions, and formatting changes
Case wdRevisionInsert, wdRevisionDelete, 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
ElseIf oRevision.Type = wdRevisionDelete Then
.Cells(3).Range.Text = "Deleted"
'Apply red color
oRow.Range.Font.Color = wdColorRed
Else
.Cells(3).Range.Text = "DCD related" 'sth
oRow.Range.Font.Color = wdColorAutomatic
End If

'The section name


Debug.Print
oRevision.Range.Information(wdActiveEndSectionNumber)

'.Cells(4).Range.Text = _

Sections(oRevision.Range.Information(wdActiveEndSectionNumber)) _
.Range.Paragraphs(1).Range.Text

'Changed text
.Cells(5).Range.Text = strText

'The revision date FYR


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

'If no chagnes were found, show message and close oNewDoc


If n = 0 Then
MsgBox "No changes 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. " & _
"Finished creating document.", vbOKOnly, Title

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

End Sub

You might also like

pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy