Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 01-09-2017, 09:44 PM
BABZ BABZ is offline Windows 10 Office 2016
Novice
 
Join Date: Jan 2017
Posts: 1
BABZ is on a distinguished road
Post Macro in Word to track colour of highlighted text

Hi everyone,



I want to add a column to the below text to track text that is highlighted and the colour I highlighted in. For instance, I will highlight texts "green" and want the below table to track that the text was highlighted and in green. How would I do this? HELP, please!!


Code:
Sub CODINGText()
Dim oDoc As Document
    Dim oNewDoc As Document
    Dim oTable As Table
    Dim nCount As Long
    Dim n As Long
    Dim Title As String
    
    Title = "Extract All Comments to New Document"
    Set oDoc = ActiveDocument
    nCount = ActiveDocument.Comments.Count
    
    If nCount = 0 Then
        MsgBox "The active document contains no comments.", vbOKOnly, Title
        GoTo ExitHere
    Else
        'Stop if user does not click Yes
        If MsgBox("Do  you want to extract all comments to a new document?", _
                vbYesNo + vbQuestion, Title) <> vbYes Then
            GoTo ExitHere
        End If
    End If
        
    Application.ScreenUpdating = False
    'Create a new document for the comments, base on Normal.dotm
    Set oNewDoc = Documents.Add
    'Set to landscape
    oNewDoc.PageSetup.Orientation = wdOrientLandscape
    'Insert a 5-column table for the comments
    With oNewDoc
        .Content = ""
        Set oTable = .Tables.Add _
            (Range:=Selection.Range, _
            numrows:=nCount + 1, _
            NumColumns:=5)
    End With
    
    'Insert info in header - change date format as you wish
    oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
        "Comments extracted from: " & oDoc.FullName & vbCr & _
        "Created by: " & Application.UserName & vbCr & _
        "Creation date: " & Format(Date, "MMMM d, yyyy")
            
    'Adjust the Normal style and Header style
    With oNewDoc.Styles(wdStyleNormal)
        .Font.Name = "Times New Roman"
        .Font.Size = 12
        .ParagraphFormat.LeftIndent = 0
        .ParagraphFormat.SpaceAfter = 6
    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
        .Columns.PreferredWidthType = wdPreferredWidthPercent
        .Columns(1).PreferredWidth = 10
        .Columns(2).PreferredWidth = 23
        .Columns(3).PreferredWidth = 42
        .Columns(4).PreferredWidth = 18
        .Columns(5).PreferredWidth = 12
        
        .Rows(1).HeadingFormat = True
    End With

    'Insert table headings
    With oTable.Rows(1)
        .Range.Font.Bold = True
        .Cells(1).Range.Text = "Page/Line #"
        .Cells(2).Range.Text = "Textual Data/Comment Scope"
        .Cells(3).Range.Text = "Code/ Comment text"
        .Cells(4).Range.Text = "Author"
        .Cells(5).Range.Text = "Date"
       
        
    End With
    
    'Get info from each comment from oDoc and insert in table
    For n = 1 To nCount
        With oTable.Rows(n + 1)
            'Page number
            .Cells(1).Range.Text = _
                oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
            'The text marked by the comment
            .Cells(2).Range.Text = oDoc.Comments(n).Scope
            'The comment itself
            .Cells(3).Range.Text = oDoc.Comments(n).Range.Text
            'The comment author
            .Cells(4).Range.Text = oDoc.Comments(n).Author
            'The comment date in format dd-MMM-yyyy
            .Cells(5).Range.Text = Format(oDoc.Comments(n).Date, "dd-MMM-yyyy")
            
            
            
        End With
    Next n
    
    Application.ScreenUpdating = True
    Application.ScreenRefresh
        
    oNewDoc.Activate
    MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title

ExitHere:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oTable = Nothing

End Sub
Code:
Sub EXTRACTtrackchange()
'
' EXTRACTtrackchange Macro
'
'
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 = "Extract Tracked Changes to New Document"
    n = 0 'use to count extracted changes
    
    Set oDoc = ActiveDocument
    
    If oDoc.Revisions.Count = 0 Then
        MsgBox "The active document contains no tracked changes.", vbOKOnly, Title
        GoTo ExitHere
    Else
        'Stop if user does not click Yes
        If 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 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 = _
        "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 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 = 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 date
    End With

    'Insert table headings
    With 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 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 = "Inserted"
                        'Apply automatic color (black on white)
                        oRow.Range.Font.Color = wdColorAutomatic
                    Else
                        .Cells(3).Range.Text = "Deleted"
                        '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 "No insertions or deletions were found.", 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 & " tracked changed have been extracted. " & _
        "Finished creating document.", vbOKOnly, Title

ExitHere:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oTable = Nothing
    Set oRow = Nothing
    Set oRange = Nothing
End Sub

Last edited by macropod; 01-09-2017 at 10:14 PM. Reason: Added code tags
Reply With Quote
  #2  
Old 01-09-2017, 10:33 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 14,897
macropod is a name known to allmacropod is a name known to allmacropod is a name known to allmacropod is a name known to allmacropod is a name known to allmacropod is a name known to all
Default

You posted two macros, the first of which concerns only comments, not tracked changes.

For the second macro, you would presumably need to add and format another column to the table it creates, in the sections after:
'Insert a 6-column table for the tracked changes and metadata
'Format the table appropriately
'Insert table headings
then output the tracked highlights to that column, by modifying the code after:
'Get info from each tracked change (insertion/deletion) from oDoc and insert in table
Highlights would be included in:
Case wdRevisionProperty
but so too are formatting changes, for example. And, although you can test whether the revision range is highlighted, Word can't tell you whether the revision was the highlighting or, say, a change to the font formatting that happens to span the same range. The only way to find that out would be to reject or accept the revision, test whether the highlighting is still there, then undo the reject or accept.

You'd presumably also want to change the prompts.
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Reply With Quote
Reply

Tags
add-in, highlighted-text, marco
Please reply to this thread with any new information or opinions.

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
How do I select all text highlighted in a specific colour? bertietheblue Word 2 04-15-2016 12:30 PM
I need to convert shaded text into highlighted text on about 80 different long documents. VBA macro? AustinBrister Word VBA 8 05-28-2015 02:42 PM
How to filter sentences wth highlighted colour rajpes Word 4 02-25-2011 12:43 AM
Macro to mark non-coloured/non-highlighted text as hidden PeterB Word 0 10-28-2009 07:54 AM
track changes author colour issues Mesana Word 0 07-17-2009 06:25 AM


All times are GMT -7. The time now is 01:29 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft