Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 07-24-2019, 04:31 AM
doeclapton doeclapton is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 7 64bit Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2010
Novice
Help on Extracting Header Outline Level Of Tracked Changes to New Document
 
Join Date: Jul 2019
Posts: 8
doeclapton is on a distinguished road
Unhappy 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
Reply With Quote
  #2  
Old 07-24-2019, 06:44 AM
gmaxey gmaxey is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 10 Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,421
gmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the rough
Default

.Cells(2).Range.Text = oRevision.Range.Paragraphs(1).OutlineLevel
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #3  
Old 07-24-2019, 06:50 AM
Pecoflyer's Avatar
Pecoflyer Pecoflyer is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 7 64bit Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2010 64bit
Expert
 
Join Date: Nov 2011
Location: Brussels Belgium
Posts: 2,766
Pecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant futurePecoflyer has a brilliant future
Default

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
Reply With Quote
  #4  
Old 07-24-2019, 07:07 AM
gmaxey gmaxey is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 10 Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,421
gmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the roughgmaxey is a jewel in the rough
Default

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.
__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #5  
Old 07-25-2019, 12:56 AM
doeclapton doeclapton is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 7 64bit Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2010
Novice
Help on Extracting Header Outline Level Of Tracked Changes to New Document
 
Join Date: Jul 2019
Posts: 8
doeclapton is on a distinguished road
Default

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!
Reply With Quote
  #6  
Old 07-25-2019, 01:31 AM
Guessed's Avatar
Guessed Guessed is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 10 Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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
Reply With Quote
  #7  
Old 07-25-2019, 03:42 AM
doeclapton doeclapton is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 7 64bit Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2010
Novice
Help on Extracting Header Outline Level Of Tracked Changes to New Document
 
Join Date: Jul 2019
Posts: 8
doeclapton is on a distinguished road
Default

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.
Reply With Quote
  #8  
Old 07-25-2019, 04:30 PM
Guessed's Avatar
Guessed Guessed is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 10 Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 3,932
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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
Reply With Quote
  #9  
Old 08-12-2019, 01:30 AM
doeclapton doeclapton is offline Help on Extracting Header Outline Level Of Tracked Changes to New Document Windows 7 64bit Help on Extracting Header Outline Level Of Tracked Changes to New Document Office 2010
Novice
Help on Extracting Header Outline Level Of Tracked Changes to New Document
 
Join Date: Jul 2019
Posts: 8
doeclapton is on a distinguished road
Default

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!
Reply With Quote
Reply

Tags
headers, macro, tracked changes

Thread Tools
Display Modes


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
Help on Extracting Header Outline Level Of Tracked Changes to New Document Outline mode: does not go to next level ward calaway Word 4 05-27-2016 04:24 PM
Help on Extracting Header Outline Level Of Tracked Changes to New Document What is Outline Level mmoid2015 Word 1 01-16-2015 03:55 AM
Help on Extracting Header Outline Level Of Tracked Changes to New Document Paragraph Outline level changes bburns Word 10 07-16-2013 02:34 AM
Help on Extracting Header Outline Level Of Tracked Changes to New Document Heading level numbering in 2010 - wrong after second header level 1 taran Word 3 07-08-2013 01:12 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 03:36 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft