lamboman
11-06-2008, 06:39 AM
Greetings,
I am being troubled by an automation error (the object invoked has disconnected from its clients) and I cannot figure why it happens sporadically.
XP/2003 (Word 2003)
My small macro basically performs a document compare and then captures the resultant underlined text/revisions and displays them tabularly.
(similar to a macro for capturing tacked changes).
However, on small documents it runs fine, but if the document is large (over 100 pages and possibly contains a linked TOC), i seem to sporadically get the error.
Any ideas?
greatly appreciated.
Private Sub CommandButton1_Click()
DC.hide
Dim oDoc1 As Word.Document
Dim oResDoc As Word.Document
Set oDoc1 = ActiveDocument
'the line below is for xp and 2003
' comparing Document 1 with New 1.doc
oDoc1.Compare Name:=lstfiles.Value, CompareTarget:=wdCompareTargetNew, DetectFormatChanges:=True
'This will be the result document
Set oResDoc = ActiveDocument
If oResDoc.Revisions.Count <> 0 Then
'code for generation of revision table
If ActiveDocument.Revisions.Count = 0 Then
MsgBox "There were no differences between the two documents"
End
End If
'get rid of hyperlinks
ActiveDocument.Fields.Unlink
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 = "MS Word Document Comparison Report"
n = 0 'use to count extracted changes
Set oDoc = ActiveDocument
If oDoc.Revisions.Count = 0 Then
MsgBox "There are 0 (zero) differences.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Differences between the two documents have been detected" & vbCr & vbCr & _
" " & _
"Click Yes to generate document comparison report", _
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 = _
"Document Comparison Report for: " & lstfiles.Value & vbCr & _
"Compared by: " & Application.UserName & vbCr & _
"Comparison 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 = 3 'Page
.Columns(2).PreferredWidth = 3 'Line
.Columns(3).PreferredWidth = 5 'Action
.Columns(4).PreferredWidth = 10 'Revision Type
.Columns(5).PreferredWidth = 1 'Technical Writer/User ID
.Columns(6).PreferredWidth = 1 '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 = "Performed Action"
.Cells(4).Range.Text = "Content"
.Cells(5).Range.Text = "User"
.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
'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 = "Insertion"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
Else
.Cells(3).Range.Text = "Deletion"
'Apply red color
oRow.Range.Font.Color = wdColorRed
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 "There were no revisions to this document.", 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 & " individual document differences have been extracted" & _
"", vbOKOnly, Title
'delete the 2 columns and add title
With oTable.Rows(1)
Selection.MoveRight Unit:=wdCharacter, Count:=43
Selection.MoveLeft Unit:=wdCharacter, Count:=8
Selection.Columns.Delete
Selection.Columns.Delete
Selection.SplitTable
Selection.Font.Bold = wdToggle
Selection.Font.Size = 11
Selection.TypeText Text:="Microsoft Word Document Comparison Report for- "
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="DocName"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
With ActiveDocument
.Bookmarks("DocName").Range.Text = lstfiles.Value
End With
End With
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
oResDoc.Close savechanges:=False
Else
MsgBox "MS Word Document Comparison Completed: There were 0 changes detected"
End If
Unload Me
End Sub
I am being troubled by an automation error (the object invoked has disconnected from its clients) and I cannot figure why it happens sporadically.
XP/2003 (Word 2003)
My small macro basically performs a document compare and then captures the resultant underlined text/revisions and displays them tabularly.
(similar to a macro for capturing tacked changes).
However, on small documents it runs fine, but if the document is large (over 100 pages and possibly contains a linked TOC), i seem to sporadically get the error.
Any ideas?
greatly appreciated.
Private Sub CommandButton1_Click()
DC.hide
Dim oDoc1 As Word.Document
Dim oResDoc As Word.Document
Set oDoc1 = ActiveDocument
'the line below is for xp and 2003
' comparing Document 1 with New 1.doc
oDoc1.Compare Name:=lstfiles.Value, CompareTarget:=wdCompareTargetNew, DetectFormatChanges:=True
'This will be the result document
Set oResDoc = ActiveDocument
If oResDoc.Revisions.Count <> 0 Then
'code for generation of revision table
If ActiveDocument.Revisions.Count = 0 Then
MsgBox "There were no differences between the two documents"
End
End If
'get rid of hyperlinks
ActiveDocument.Fields.Unlink
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 = "MS Word Document Comparison Report"
n = 0 'use to count extracted changes
Set oDoc = ActiveDocument
If oDoc.Revisions.Count = 0 Then
MsgBox "There are 0 (zero) differences.", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Differences between the two documents have been detected" & vbCr & vbCr & _
" " & _
"Click Yes to generate document comparison report", _
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 = _
"Document Comparison Report for: " & lstfiles.Value & vbCr & _
"Compared by: " & Application.UserName & vbCr & _
"Comparison 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 = 3 'Page
.Columns(2).PreferredWidth = 3 'Line
.Columns(3).PreferredWidth = 5 'Action
.Columns(4).PreferredWidth = 10 'Revision Type
.Columns(5).PreferredWidth = 1 'Technical Writer/User ID
.Columns(6).PreferredWidth = 1 '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 = "Performed Action"
.Cells(4).Range.Text = "Content"
.Cells(5).Range.Text = "User"
.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
'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 = "Insertion"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
Else
.Cells(3).Range.Text = "Deletion"
'Apply red color
oRow.Range.Font.Color = wdColorRed
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 "There were no revisions to this document.", 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 & " individual document differences have been extracted" & _
"", vbOKOnly, Title
'delete the 2 columns and add title
With oTable.Rows(1)
Selection.MoveRight Unit:=wdCharacter, Count:=43
Selection.MoveLeft Unit:=wdCharacter, Count:=8
Selection.Columns.Delete
Selection.Columns.Delete
Selection.SplitTable
Selection.Font.Bold = wdToggle
Selection.Font.Size = 11
Selection.TypeText Text:="Microsoft Word Document Comparison Report for- "
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="DocName"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
With ActiveDocument
.Bookmarks("DocName").Range.Text = lstfiles.Value
End With
End With
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
oResDoc.Close savechanges:=False
Else
MsgBox "MS Word Document Comparison Completed: There were 0 changes detected"
End If
Unload Me
End Sub