TrackRevisions：包含原始文本和最终文本的表格

问题描述

我对 vba 很陌生，我需要编写一个脚本，该脚本的输入是经过一些修订的文档。对于每个段落，我希望在表格中包含原始文本（无修订）和最终文本（好像所有修订都已被接受）。如果这太难了，我希望至少有一个表格，其中包含新文本、原始文档中的段落编号以及最终版本中的段落编号

这里是脚本输入的示例

这里是我想要的输出

这是我能做的。我无法获得原始文本，并且在插入多个短语的情况下，脚本只能将第一个识别为新行。 该脚本遍历所有段落，如果该段落不包含修订，则仅将文本添加到表格中。如果文本在列表中包含一个修订，除了最后一个修订之外的所有修订都被接受，如果最后修订是插入，那么如果所有修订之前和之后的段落文本都被接受，则下一段被视为新行。如果最后一次修订是删除，那么如果所有修订被接受之前的段落文本与修订文本相同，则该文本段落被视为被删除。

Sub TrackchangesTable()

    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 Title As String
    Dim Para As Paragraph
    Dim NewLine As Boolean
    Dim DraftText As String
    Dim NewId As Long
    Dim OldId As Long
    Dim OldText As String
    Dim Stile As String
    Dim OriginalDoc As Document
    
    Set odoc = ActiveDocument

    
    If odoc.Revisions.Count = 0 Then
        MsgBox "The active document contains no tracked changes.",vbOKOnly,Title
        GoTo ExitHere
    Else
        If MsgBox("Do  you want to extract tracked changes to a new document?" & vbCr & vbCr &,_
                vbYesNo + vbQuestion) <> vbYes Then
            GoTo ExitHere
        End If
    End If
        
    Application.ScreenUpdating = False
    Set oNewDoc = Documents.Add
    oNewDoc.PageSetup.Orientation = wdOrientLandscape
    With oNewDoc
        .Content = ""
        With .PageSetup
            .LeftMargin = CentimetersToPoints(2)
            .RightMargin = CentimetersToPoints(2)
            .TopMargin = CentimetersToPoints(2.5)
        End With

        Set oTable = .Tables.Add _
            (Range:=Selection.Range,_
            numrows:=1,_
            NumColumns:=7)
    End With
    
            
    With oNewDoc.Styles(wdStylenormal)
        With .Font
            .Name = "Arial"
            .Size = 9
            .Bold = False
        End With
        With .ParagraphFormat
            .LeftIndent = 0
        End With
    End With
    
    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  'Note
        .Columns(3).PreferredWidth = 10 'Final Text
        .Columns(4).PreferredWidth = 15 'Inserted/deleted text
        .Columns(5).PreferredWidth = 15 'Old Id
        .Columns(6).PreferredWidth = 10 'New ID
        .Columns(7).PreferredWidth = 10 'Stile
    End With

    With oTable.Rows(1)
        .Cells(1).Range.Text = "Page"
        .Cells(2).Range.Text = "Note"
        .Cells(3).Range.Text = "Final Text"
        .Cells(4).Range.Text = "Deleted Text"
        .Cells(5).Range.Text = "Old Id"
        .Cells(6).Range.Text = "New Id"
        .Cells(7).Range.Text = "stile"
    End With
    
    NewLine = False
    OldId = 1
    NewId = 1
    
    For Each Para In ThisDocument.Paragraphs
        Stile = Para.Range.Style
        If Para.Range.Revisions.Count = 0 And NewLine = False Then
            StrTextFinale = Para.Range.Text
        ElseIf Para.Range.Revisions.Count = 0 And NewLine = True Then
            StrTextFinale = Para.Range.Text
            Note = "New Line"
            NewLine = False
            OldId = OldId - 1
        ElseIf Para.Range.Revisions.Count > 0 Then
            For i = 1 To Para.Range.Revisions.Count
                If i < Para.Range.Revisions.Count Then
                    Para.Range.Revisions(i).Accept
                Else
                    If Para.Range.Revisions(i).Type = wdRevisionInsert Then
                        DraftText = Para.Range.Text
                        Para.Range.Revisions(i).Accept
                        StrTextFinale = Para.Range.Text
                        If DraftText = StrTextFinale Then
                            NewLine = True
                        End If
                    ElseIf Para.Range.Revisions(i).Type = wdRevisionDelete Then
                        DraftText = Para.Range.Revisions(i).Range.Text
                        StrTextFinale = Para.Range.Text
                        If DraftText = StrTextFinale Then
                            Note = "Testo eliminato"
                            StrTextFinale = "volutamente cancellato"
                            OldText = Para.Range.Text
                            NewId = NewId - 1
                        Else
                            Para.Range.Revisions(i).Accept
                            StrTextFinale = Para.Range.Text
                        End If
                    End If
                End If
            Next
        End If
        
        Set oRow = oTable.Rows.Add
    
        With oRow
            .Cells(1).Range.Text = Para.Range.information(wdActiveEndAdjustedPageNumber)
            .Cells(2).Range.Text = Note
            .Cells(3).Range.Text = StrTextFinale
            .Cells(4).Range.Text = OldText
            .Cells(5).Range.Text = OldId
            .Cells(6).Range.Text = NewId
            .Cells(7).Range.Text = Stile
            Note = ""
        End With
    OldId = OldId + 1
    NewId = NewId + 1
    OldText = ""
    Next
    

    With oTable.Rows(1)
        .Range.Font.Bold = True
        .headingFormat = True
    End With
    
    Application.ScreenUpdating = True
    Application.ScreenRefresh
        
    MsgBox ("Over")

    ExitHere:
        Set odoc = nothing
        Set oNewDoc = nothing
        Set oTable = nothing
        Set oRow = nothing
        Set oRange = nothing
    
End Sub

有人可以帮我改进这个脚本吗？

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）