none
Macro to Make Track Changes Permanent in MS-Word and then Accept Permanent Track Changes RRS feed

  • Question

  • Below is some code from Cindy Meister to Make Track Changes Permanent in MS-Word which works very well.  My question is how can you then "Accept Permanent Track Changes" (new macro?) that leaves a document of clean text without any regular or permanent track changes?  

    From Cindy:  Here's a bit of sample code you can try. It's designed to pick up all the
    different kinds of revisions. Just put an apostrophe in front of the lines you
    don't want to execute.

    Sub FormatRevisions()
        Dim doc As Word.Document
        Dim rev As Word.Revision
       
        Set doc = ActiveDocument
        doc.TrackRevisions = False
        For Each rev In doc.Revisions
            Select Case rev.Type
                Case wdRevisionDelete
                    rev.Range.Font.StrikeThrough = True
                    rev.Reject
                Case wdRevisionInsert
                    rev.Range.Underline = wdUnderlineSingle
                    rev.Accept
                Case wdRevisionFormat
                     MsgBox "revision format"
                    rev.Accept
                Case wdRevisionStyle
                     MsgBox "revision style"
                    rev.Accept
                Case wdRevisionStyleDefinition
                     MsgBox "revision style def"
                    rev.Accept
                Case wdRevisionSectionProperty
                     MsgBox "revision section prop"
                    rev.Accept
                Case wdRevisionReplace
                     MsgBox "revision replace"
                    rev.Accept
                Case wdRevisionTableProperty
                     MsgBox "revision table property"
                    rev.Accept
                Case wdRevisionReconcile
                     MsgBox "revision reconcile"
                    rev.Accept
                Case wdRevisionProperty
                     MsgBox "revision property"
                    rev.Accept
                Case wdRevisionParagraphProperty
                     MsgBox "revision para property"
                    rev.Accept
                Case wdRevisionParagraphNumber
                     MsgBox "revision para number"
                    rev.Accept
                Case wdRevisionDisplayField
                     MsgBox "revision display field"
                    rev.Accept
                Case wdRevisionConflict
                    MsgBox "revision conflict"
                    rev.Accept
                Case wdNoRevision
                    MsgBox "no revision"
                    rev.Accept
                Case Else
                    MsgBox "unknown type"
                    doc.Comments.Add rev.Range, "unknown type"
            End Select
        Next
    End Sub

    Wade McCartney
    wademcc@gmail.com

    Monday, July 16, 2012 6:39 PM

Answers

  • Hi Wade

    I must admit, I'd forgotten all about this macro...

    As you can see from the code, what it essentially does is replace the changes with static font formatting: strikethrough and underline.

    Simply put, you could simply remove these things from the document. One possibility would be to use FindReplace to Find the two types of formatting and replace them with the reverse (no strikethrough resp. no underline).

    But in reality, this kind of formatting might be present in the document, otherwise, and shouldn't be removed. So you need to have a method to recognize these things. I'm considering various approaches, but the one that seems best would be to set bookmarks around these ranges. Then you can loop through the bookmarks, remove the formatting and delete the bookmark.

    Sample VBA code is below. I haven't duplicated the entire original macro, only the two cases with the formatting. A separate sub is called to create the bookmark and increment the counter that makes the names unique. The third sub removes the formatting and the bookmarks. You don't say, so I don't know if you also want the strikethrough text to be deleted - I've added that line as well and commented it out.

    Sub FormatRevisions()
        Dim doc As word.Document
        Dim rev As word.Revision
        Dim bkm As word.Bookmark
        Dim rng As word.Range
        Dim revBkm As String
        Dim revBkmCounter As Long
        
        revBkm = "RevMark"
        revBkmCounter = 1
        Set doc = ActiveDocument
        doc.TrackRevisions = False
        For Each rev In doc.Revisions
            Select Case rev.Type
                Case wdRevisionDelete
                    Set rng = rev.Range
                    rng.Font.StrikeThrough = True
                    AddBookmark rng, revBkm, revBkmCounter
                    rev.Reject
                Case wdRevisionInsert
                    Set rng = rev.Range
                    rev.Range.Underline = wdUnderlineSingle
                    AddBookmark rng, revBkm, revBkmCounter
                    rev.Accept
            End Select
        Next
    End Sub
    Private Sub AddBookmark(rng As word.Range, bkmName As String, ByRef counter As Long)
        rng.Bookmarks.Add bkmName & counter, rng
        counter = counter + 1
    End Sub
    Sub RemoveRevFormatting()
        Dim doc As word.Document
        Dim bkm As word.Bookmark
        Dim revBkmName As String
        Dim rng As word.Range
        
        revBkmName = "RevMark"
        Set doc = ActiveDocument
        For Each bkm In doc.Bookmarks
            If Left(bkm.Name, Len(revBkmName)) = revBkmName Then
                Set rng = bkm.Range
                If rng.Underline = wdUnderlineSingle Then
                    rng.Underline = wdUnderlineNone
                End If
                If rng.Font.StrikeThrough = True Then
                    rng.Font.StrikeThrough = False
                    'rng.Delete
                End If
            End If
            bkm.Delete
        Next
    End Sub


    Cindy Meister, VSTO/Word MVP

    Tuesday, July 17, 2012 5:02 PM
    Moderator