|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Help on Extracting Header Outline Level Of Tracked Changes to New Document
I am desperate for help on how to extract outline levels of a section being tracked for changes.
I would like to extract the following: screenie.jpg Currently my code looks like this: 'Macro created 2007 by Lene Fredborg, DocTools - 'The macro creates a new document 'and extracts insertions and deletions 'marked as tracked changes from the active document 'NOTE: Other types of changes are skipped '(e.g. formatting changes or inserted/deleted footnotes and endnotes) 'Only insertions and deletions in the main body of the document will be extracted 'The document will also include metadata 'Inserted text will be applied black font color 'Deleted text will be applied red font color 'Minor adjustments are made to the styles used 'You may need to change the style settings and table layout to fit your needs '========================= Code:
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 Now instead of the line number, I would like to extract the header outline level. The proposed output would be like this: Proposed Output of Main Document.docx Here is the main document for testing with the macro enabled: Main Document.docm Thank you so much for your help on this. I really need your expertise on this one! Last edited by Pecoflyer; 07-24-2019 at 06:49 AM. Reason: Removed ink - Added code tags |
#2
|
|||
|
|||
.Cells(2).Range.Text = oRevision.Range.Paragraphs(1).OutlineLevel
|
#3
|
||||
|
||||
Hi and welcome
in the future please wrap code with code tags ( #button) Thanks
__________________
Did you know you can thank someone who helped you? Click on the tiny scale in the right upper hand corner of your helper's post |
#4
|
|||
|
|||
Pecoflyer,
I have been around here long enough that perphaps I should be the one welcoming you! I don't need you playing mother hen for my post. I don't think there is much risk of confusing code wrapped in code tags with anything else when the only thing I post is a line of code. |
#5
|
|||
|
|||
Thank you gmaxey!
However that line only outputted a single value. I've come across this other thread that accurately describes what I'm looking for: c# - getting the heading of a selected text in word - Stack Overflow However since this is my literal first time doing this kind of stuff, I am still left puzzled on what to do. How can I incorporate their functions into my currently existing code? Thanks a lot! |
#6
|
||||
|
||||
You aren't being clear about what you want - largely because this is potentially a lot more complicated than you might have supposed.
An Outline Level is a number between 1 and 10 which is an attribute applied to each paragraph. Typically the outline levels correspond with the Heading styles from 1-9 with 10 being used for just about everything else. The numbers you highlighted in your screen grabs are NOT outline levels. They are either a paragraph number (or ListStrings in vba-speak) or perhaps are hard-coded content in a paragraph. Also, those numbers could be on Headings or other paragraph types. Because a single tracked revision could include multiple paragraphs which can span multiple numbered and unnumbered paragraphs you need to be very clear as to what you want to happen. Do we just look at the first paragraph? If that isn't numbered, do we step backwards to find the nearest preceding number (or outline level)? Or do we step backwards to find the nearest preceding heading.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#7
|
|||
|
|||
Apologies for the ambiguity. I have now attached a new screenshot detailing what I really need.
screenie2.jpg Basically what I really need are complete header values of every tracked section from the most topmost level to its current level. Does this make any sense now? Appreciate your patience on this one. |
#8
|
||||
|
||||
This is a bigger job than I have the time or appetite to solve at the moment so I'll just add some info in the hope that you might be able to solve it yourself.
Assuming the 3 levels of numbers are all in the same outline list, you might be able to extract them in two different ways. 1. Create an iterative loop that works out the current level (eg 3) then searches back for the preceding level 2 then the preceding level 1. 2. Create a temporary Ref field (a cross reference) at that point and include the full context switch '\w' to concatenate the relevant levels. Harvest the value of that field before removing it. Your example appears to show a single tracked revision (its all red and underlined) so that is a problem you will need to solve by testing each paragraph in the tracked revision to find out if it is numbered. If none of the paragraphs are numbered, is the macro to search up through the document until it finds a numbered (or heading) paragraph? Or does it not report a number?
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#9
|
|||
|
|||
We have been able to make a separate function that now returns the appropriate header level. However, a new issue appeared. Word now crashes everytime the Macro is run on some large files.
I'll be attaching the two modules in here along with the test documents. Macro Modules: ExtractEdryl.zip Test documents: Test Documents.zip Would you be able to help me in figuring out how to avoid these file crashes? Thanks! |
Tags |
headers, macro, tracked changes |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Help on Extracting Outline Level Of Tracked Changes To New Document | doeclapton | Word VBA | 1 | 07-24-2019 07:01 AM |
Outline mode: does not go to next level | ward calaway | Word | 4 | 05-27-2016 04:24 PM |
What is Outline Level | mmoid2015 | Word | 1 | 01-16-2015 03:55 AM |
Paragraph Outline level changes | bburns | Word | 10 | 07-16-2013 02:34 AM |
Heading level numbering in 2010 - wrong after second header level 1 | taran | Word | 3 | 07-08-2013 01:12 PM |