Posts by amardep20

[/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