VBA Tracked Changes HELP

  • Hi guys,

    I need your help here...

    i'm trying to create a VBA code to pull trakced changes from a document and display it in a newly created document.

    Does anyone know how i need to change this code so that it also picks up the insertions and deletions form header and footer of the document.

    the below code will extract only the insertions and deletions of main body but i've tried a few edits and nothing seems to work

    Thanks guys


    [/SIZE]Dim oDoc As DocumentDim oNewDoc As DocumentDim oTable As TableDim oRow As RowDim oCol As ColumnDim oRange As RangeDim oRevision As RevisionDim strText As StringDim n As LongDim i As LongDim Title As StringTitle = "Extract Tracked Changes to New Document"n = 0 'use to count extracted changesSet oDoc = ActiveDocumentIf oDoc.Revisions.Count = 0 ThenMsgBox "The active document contains no tracked changes.", vbOKOnly, TitleGoTo ExitHereElse'Stop if user does not click YesIf MsgBox("Do you want to extract tracked changes to a new document?" & vbCr & vbCr & _"NOTE: Only insertions and deletions will be included. " & _"All other types of changes will be skipped.", _vbYesNo + vbQuestion, Title) <> vbYes ThenGoTo ExitHereEnd IfEnd IfApplication.ScreenUpdating = False'Create a new document for the tracked changes, base on Normal.dotSet oNewDoc = Documents.Add'Set to landscapeoNewDoc.PageSetup.Orientation = wdOrientLandscapeWith oNewDoc'Make sure any content is deleted.Content = ""'Set appropriate marginsWith .PageSetup.LeftMargin = CentimetersToPoints(2).RightMargin = CentimetersToPoints(2).TopMargin = CentimetersToPoints(2.5)End With'Insert a 6-column table for the tracked changes and metadataSet oTable = .Tables.Add _(Range:=Selection.Range, _numrows:=1, _NumColumns:=6)End With'Insert info in header - change date format as you wishoNewDoc.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 styleWith oNewDoc.Styles(wdStyleNormal)With .Font.Name = "Arial".Size = 9.Bold = FalseEnd WithWith .ParagraphFormat.LeftIndent = 0.SpaceAfter = 6End WithEnd WithWith oNewDoc.Styles(wdStyleHeader).Font.Size = 8.ParagraphFormat.SpaceAfter = 0End With'Format the table appropriatelyWith oTable.Range.Style = wdStyleNormal.AllowAutoFit = False.PreferredWidthType = wdPreferredWidthPercent.PreferredWidth = 100For Each oCol In .ColumnsoCol.PreferredWidthType = wdPreferredWidthPercentNext 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 dateEnd With'Insert table headingsWith oTable.Rows(1).Cells(1).Range.Text = "Page".Cells(2).Range.Text = "Line".Cells(3).Range.Text = "Type".Cells(4).Range.Text = "What has been inserted or deleted".Cells(5).Range.Text = "Author".Cells(6).Range.Text = "Date"End With'Get info from each tracked change (insertion/deletion) from oDoc and insert in tableFor Each oRevision In oDoc.RevisionsSelect Case oRevision.Type'Only include insertions and deletionsCase wdRevisionInsert, wdRevisionDelete'In case of footnote/endnote references (appear as Chr(2)),'insert "[footnote reference]"/"[endnote reference]"With oRevision'Get the changed textstrText = .Range.TextSet oRange = .RangeDo While InStr(1, oRange.Text, Chr(2)) > 0'Find each Chr(2) in strText and replace by appropriate texti = InStr(1, strText, Chr(2))If oRange.Footnotes.Count = 1 ThenstrText = Replace(Expression:=strText, _Find:=Chr(2), Replace:="[footnote reference]", _Start:=1, Count:=1)'To keep track of replace, adjust oRange to start after ioRange.Start = oRange.Start + iElseIf oRange.Endnotes.Count = 1 ThenstrText = Replace(Expression:=strText, _Find:=Chr(2), Replace:="[endnote reference]", _Start:=1, Count:=1)'To keep track of replace, adjust oRange to start after ioRange.Start = oRange.Start + iEnd IfLoopEnd With'Add 1 to countern = n + 1'Add row to tableSet oRow = oTable.Rows.Add'Insert data in cells in oRowWith 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 revisionIf oRevision.Type = wdRevisionInsert Then.Cells(3).Range.Text = "Inserted"'Apply automatic color (black on white)oRow.Range.Font.Color = wdColorAutomaticElse.Cells(3).Range.Text = "Deleted"'Apply red coloroRow.Range.Font.Color = wdColorRedEnd 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 WithEnd SelectNext oRevision'If no insertions/deletions were found, show message and close oNewDocIf n = 0 ThenMsgBox "No insertions or deletions were found.", vbOKOnly, TitleoNewDoc.Close savechanges:=wdDoNotSaveChangesGoTo ExitHereEnd If'Apply bold formatting and heading format to row 1With oTable.Rows(1).Range.Font.Bold = True.HeadingFormat = TrueEnd WithApplication.ScreenUpdating = TrueApplication.ScreenRefreshoNewDoc.ActivateMsgBox n & " tracked changed have been extracted. " & _"Finished creating document.", vbOKOnly, TitleExitHere:Set oDoc = NothingSet oNewDoc = NothingSet oTable = NothingSet oRow = NothingSet oRange = NothingEnd Sub



Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!