#1
|
|||
|
|||
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 |
#2
|
||||
|
||||
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 [Fmr MS MVP - Word] |
Tags |
add-in, highlighted-text, marco |
|
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 |