Macro for Word to remove Track Changes

[richiwatts]

I have had a reviewer that has delete too much text in a few of my files. Is there a way to search and remove certain deleted texts

e.g
My reviewer has dleted everything between {0*<}0{>
{0>Hvgp Vendor Class<}0{>

It would take me hours to undo just these changes manually. I hope someone has an idea how to resolve this.

Thanks

 

[PHV]

What about simply restore a backup ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[richiwatts]

Because I still need most of the deletes the reviewer has done but remove the ones between
{0*<}0{>

 

[TonyJollans]

This is not a simple operation and, to be honest, would probably be easier done manually as it is a one-off. When you say it would take you hours, just how big is your document and how many tracked changes are in it?

Enjoy,
Tony

------------------------------------------------------------------------------------
We want to help you; help us to do it by reading this: Before you ask a question.

Professional Office Developers Association

 

[richiwatts]

10 documents and 80,000 words

 

[MakeItSo]

Hi Richie,

what has been deleted are source segments of an unclean trados file. I take it the reviewer has "corrected" the segments manually, i.e. was not using a tm?
Bad thing.
Was he at least using track changes?
In this case you could use a macro that would cycle through all changes and if the change contained a trados mark, reject the revision, else accept it.

You need to remove change tracks before cleaning to the tm anyway.

However: make sure the documents have changes tracked in the first place, else the following macro will not help you:

Sub RepairRevs()
Dim rev As Revision, doc As Document, i

With Application.FileSearch
    .LookIn = InputBox("Path ro reviewer's documents?")
    .FileName = "*.*"
    .FileType = msoFileTypeWordDocuments
    .SearchSubFolders = True
    .Execute
End With

For i = 1 To Application.FileSearch.FoundFiles.Count
    Set doc = Documents.Open(Application.FileSearch.FoundFiles(i))
    
    For Each rev In doc.Revisions
        If InStr(1, rev.Range.Text, "<}") > 0 Then 'look for mid segment marker
            rev.Reject
        Else
            rev.Accept
        End If
    Next rev
    doc.Close SaveChanges:=True
Next i

End Sub

You're lucky a localisation engineer came across...


[navy]"We had to turn off that service to comply with the CDA Bill."[/navy]
- The Bastard Operator From Hell

 

[richiwatts]

Hi Make it so,

Yes that is exactly the problem. The files was translated with Trados then sent to the client for review. They used Track changes so we could see what they had changed but one of their reviewers didn't receive instructions not to touch the hidden source. I will test the Macro now and get back to you.

Cheers

 

[richiwatts]

Hi Makeitso. It also rejects the change is the target segment instead of accepting it.

 

[MakeItSo]

Hi Richie,

darn: this will be tricky.

1) Try by replacing the

If instr(1, rev.range.text,"<}") Then

line with

If rev.Range.Font.Hidden Then

If that does not work either, than these revisions encompass both, source and target deletion.
Then we'll have to try something like this (warning: only veeery roughly tested!):

Sub RepairRevs()
Dim rev As Revision, doc As Document, i, SourceSeg As String, TargetSeg As String, j As Long
Dim pos As Integer, pos2 As Integer, delStart As Long, delEnd As Long

On Error Resume Next

With Application.FileSearch
    .LookIn = InputBox("Path ro reviewer's documents?")
    .FileName = "*.*"
    .FileType = msoFileTypeWordDocuments
    .SearchSubFolders = True
    .Execute
End With

For i = 1 To Application.FileSearch.FoundFiles.Count
    Set doc = Documents.Open(Application.FileSearch.FoundFiles(i))
    
    j = 1
    doc.TrackRevisions = True
    Do
        Set rev = doc.Revisions(j)
        If InStr(1, rev.Range.Text, "<}") > 0 And rev.Type = wdRevisionDelete Then 'look for mid segment marker
            SourceSeg = rev.Range.Revisions.Item(1).Range.Text
            'where am I?
            delStart = rev.Range.Start
            Set rev = doc.Revisions(j + 1) 'Next revision object contains the new text
            'where to?
            delEnd = rev.Range.End
            j = j + 1
            TargetSeg = rev.Range.Text
            '********
            'restore source:
            pos = InStr(1, SourceSeg, "{0>")
            pos2 = InStr(1, SourceSeg, "<}0{>")
            SourceSeg = Mid(SourceSeg, pos + 3, pos2 - 4)
            doc.TrackRevisions = False
            Selection.SetRange delStart, delEnd
            Selection.Delete
            Selection.SetRange delStart, delStart
            Selection.Style = ActiveDocument.Styles("tw4winMark")
            Selection.TypeText "{0>"
            Selection.Collapse wdCollapseEnd
            Selection.Style = ActiveDocument.Styles("Default Paragraph Font")
            Selection.TypeText SourceSeg
            Selection.Collapse wdCollapseEnd
            Selection.Style = ActiveDocument.Styles("tw4winMark")
            Selection.TypeText "<}0{>"
            Selection.Collapse wdCollapseEnd
            Selection.Style = ActiveDocument.Styles("Default Paragraph Font")
            Selection.TypeText TargetSeg
            Selection.Collapse wdCollapseEnd
            doc.TrackRevisions = True
            
            'correct loop counter, since two revisions have been removed
            j = j - 2
        Else
            rev.Accept
            j = j - 1
        End If
    Loop Until doc.Revisions.Count = 0
    
    'restore source as hidden
    doc.TrackRevisions = False
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "\{0\>*\<\}"
        .Replacement.Text = ""
        .Replacement.Font.Hidden = True
        .Format = True
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    doc.Close SaveChanges:=True
Next i

End Sub

Explanation:
Every revision consists in fact of two revisions: one that deletes the old entry, the next which inserts the new entry.
So you search each revision of type "delete" that contains a marker, then store the old source segment in a string variable, store the next revision (the new insertion/replacement) in another string variable, delete both revision ranges, and type the revised translation segment anew.

Careful: best you walk through this code with step-by-step execution first in order to make sure it actually does what you want.

Phe

http://wwww.

After this, you might best look for a dummy-safer review format first...


[navy]"We had to turn off that service to comply with the CDA Bill."[/navy]
- The Bastard Operator From Hell

 

[MakeItSo]

Just had another idea, that might be a little more reliable - and safer!

This is what I thought of:
Instead of tediously jumping around the file with "Selection" and deleting ranges, you could just as well directly "clean" the revised segments into a tm.

As you see from the above code, the "Revisions" object allows you to get your old source string back, as well as the updated target.
So you can equally ADD these half-destroyed source/target combinations to an empty TM, THEN accept all revisions, and finally clean the file to that TM which will give you all the non-destroyed remaining segments.

If you have the LSP version of trados, you can do it like this:

Sub CleanReviewersFiles()
Dim SourceSeg As String, TargSeg As String, a As Integer
Dim tw As TW4Win.Application, tm As TranslationMemory, Filez As Variant
Dim rev As Revision, doc As Document, j As Long
Dim pos As Integer, pos2 As Integer
Filez = Array("dummy")
[b]Set tw = New TW4Win.Application
tw.TranslationMemory.Open "C:\test.tmw", "automated"
Set tm = tw.TranslationMemory[/b]

'typical Trados jobfile for cleanup:
'[Cleanup]
'LogFile = C:\Trados\TW4Win\cleanup.log
'Files = x
'File1=C:\Trados\TW4Win\demo97.rtf
'...
With Application.FileSearch
    .LookIn = InputBox("Path ro reviewer's documents?")
    .FileName = "*.*"
    .FileType = msoFileTypeWordDocuments
    .SearchSubFolders = True
    .Execute
End With

'Start writing the Trados job file for automated cleanup
a = FreeFile
Open "C:\cleanjob.log" For Output As a
Print #a, "[Cleanup]"
Print #a, "LogFile=C:\templog.log"

For i = 1 To Application.FileSearch.FoundFiles.Count
    Set doc = Documents.Open(Application.FileSearch.FoundFiles(i))
    
    j = 1
    doc.TrackRevisions = True
    Do
        Set rev = doc.Revisions(j)
        If InStr(1, rev.Range.Text, "<}") > 0 Then 'look for mid segment marker
            SourceSeg = rev.Range.Text
            pos = InStr(1, SourceSeg, "{0>")
            pos2 = InStr(1, SourceSeg, "<}0{>")
            SourceSeg = Mid(SourceSeg, pos + 3, pos2 - 4)
            Set rev = doc.Revisions(j + 1) 'Next revision object contains the new text
            TargSeg = rev.Range.Text
            [b]
            tm.Search (SourceSeg)
            tm.TranslationUnit.Save TargSeg[/b]
        End If
        j = j + 1
    Loop Until j = doc.Revisions.Count
    
    ReDim Preserve Filez(i)
    Filez(i - 1) = doc.FullName
    doc.Revisions.AcceptAll
    doc.TrackRevisions = False
    doc.Close SaveChanges:=True
Next i

'Now write list of files into cleanup job file
Print #a, "Files = " & UBound(Filez)
For i = 0 To UBound(Filez) - 1
    Print #a, "File" & i + 1 & " = " & Filez(i)
Next i
Close a
[b]
tm.CleanupFiles "C.\cleanjob.log"
tm.Close
tw.Quit
[/b]
End Sub

This should give you a clean memory with all revised segments.


Hope this helps!

Cheers,
MakeItSo

[navy]"We had to turn off that service to comply with the CDA Bill."[/navy]
- The Bastard Operator From Hell

 

[richiwatts]

Thanks Makeitso for all your help

This is what another engineer helped me with that worked

Sub FixRevContainingEnglish()
 
Selection.Find.ClearFormatting
Selection.Find.text = "\{0\>*\<\}[0-9]{1,3}\{\>"
Selection.Find.Replacement.text = ""
Selection.Find.Replacement.ClearFormatting
 
With Selection.Find
   .MatchWildcards = True
   .Wrap = wdFindStop
End With
 
Selection.HomeKey wdStory
 
Dim rev As Revision
 
Do While Selection.Find.Execute
   If Selection.Range.Revisions.Count > 0 Then
      Selection.Range.Revisions.RejectAll
    End If
nextEnglish:
    Selection.Collapse wdCollapseEnd
Loop
   
 Selection.HomeKey wdStory
  
Selection.Find.text = "\<0\}"
Do While Selection.Find.Execute
   If Selection.Range.Revisions.Count > 0 Then
      Selection.Range.Revisions.RejectAll
    End If
    Selection.Collapse wdCollapseEnd
Loop
 Selection.HomeKey wdStory
 
Selection.Find.text = "?^13"
Do While Selection.Find.Execute
   Selection.MoveStart unit:=wdCharacter, Count:=1
   If Selection.Range.Revisions.Count > 0 Then
      Selection.Range.Revisions.RejectAll
    End If
    Selection.Collapse wdCollapseEnd
Loop
 
Selection.Find.Style = "tw4winMark"
Selection.Find.text = "^13"
 
Selection.Find.Execute Replace:=wdReplaceAll
 
 
 
    WordBasic.AcceptAllChangesInDoc
    
ActiveDocument.TrackRevisions = False
 

 Selection.HomeKey wdStory
 
 
Selection.Find.text = "\{\>\<0\}"
Selection.Find.ClearFormatting
 
Do While Selection.Find.Execute
    Dim rng2 As Range
    Set rng2 = Selection.Range
    Selection.Expand wdParagraph
    Selection.Collapse wdCollapseStart
    Dim s As Long
        s = Selection.start
    Do While Selection.Style <> "tw4winMark"
       Selection.MoveRight unit:=wdCharacter, Count:=1
    Loop
    Selection.start = s
    If Selection.start = Selection.End Then
       '  No text at the beginning of the paragraph.
       ' Lets check the end
       Selection.Expand wdParagraph
       Selection.MoveEnd unit:=wdCharacter, Count:=-1
       Selection.Collapse wdCollapseEnd
       s = Selection.End
       Do While Selection.Style <> "tw4winMark"
          Selection.MoveLeft unit:=wdCharacter, Count:=1
       Loop
       Selection.MoveRight unit:=wdCharacter, Count:=1
       Selection.End = s
       Selection.Cut
    Else
       Selection.Cut
    End If
    Selection.Expand wdParagraph
    Selection.Collapse wdCollapseEnd
    Selection.MoveLeft unit:=wdCharacter, Count:=4
    Selection.Paste
Loop
 

End Sub

I will never do that again. From now on I will create tables from the uncleaned segments before sending them to the client

Thanks again

 

[MakeItSo]

Excellent, Rich!
(That's exactly what we're doing here, too)
:-D

[navy]"We had to turn off that service to comply with the CDA Bill."[/navy]
- The Bastard Operator From Hell