Comment extraction - to include sections as well as page numbers

[rtwwpad]

Hi All,

I've spent a few hours browsing the web and forums but can't find an answer to this and it may well be my lack of knowledge. Extraction of comments is well covered in the code below (as cant post links - its from the doctools website)

[vba]
Public Sub ExtractCommentsToNewDoc() 'Macro created 2007 by Lene Fredborg, DocTools 'The macro creates a new document 'and extracts all comments from the active document 'incl. metadata 'Minor adjustments are made to the styles used 'You may need to change the style settings and table layout to fit your needs '========================= 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.dot Set oNewDoc = Documents.Add 'Set to landscape oNewDoc.PageSetup.Orientation = wdOrientLandscape 'Insert a 4-column table for the comments With oNewDoc .Content = "" Set oTable = .Tables.Add _ (Range:=Selection.Range, _ numrows:=nCount + 1, _ NumColumns:=4) 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 = "Arial" .Font.Size = 10 .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(1).PreferredWidth = 5 .Columns(2).PreferredWidth = 25 .Columns(3).PreferredWidth = 50 .Columns(4).PreferredWidth = 20 .Rows(1).HeadingFormat = True End With 'Insert table headings With oTable.Rows(1) .Range.Font.Bold = True .Cells(1).Range.Text = "Page" .Cells(2).Range.Text = "Comment scope" .Cells(3).Range.Text = "Comment text" .Cells(4).Range.Text = "Author" 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 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 </vba>
The documents have sections and sub-sections - by this I mean words which have had a heading style applied.

i.e.

Section 1 <- is formatted with style Heading 1

Some text <- is formatted with style normal

Section 1.1. <- is formatted with style Heading 2

Some more text <- is formatted with style normal, also has a comment encapsulating all the text on this line, which says "What do you mean?"

Section 1.1.1<- is formatted with style Heading 3

Even more text <- is formatted with style normal

Section 2 <- is formatted with style Heading 1

Wahey, onto a second section <- is formatted with style normal

If I wish to add a new col to the code found at the url above, then I can't figure out what it should be.

It currently reads

Pg 1, Selected Text - Some more txt, Comment - What do you mean?, Author - PT

I want it to read

Pg 1, Section - 1.1, Selected Text - Some more txt, Comment - What do you mean?, Author - PT

I thought the method of using wdActiveEndSectionNumber would work, but it just returns a 1 and then I realised I was calling the items sections, but they are just formatted text, they could be called Flibble 1, Flibble 1.1 which would explain why it doesn't work.

I can't see any other relvant wd Active information fields in the VBA Editor Help file (F2) and then wasn't sure if I needed to extract a style or something else?

All help appreciated.:banghead:

[rtwwpad]

Just to confuse matters, the code for extracting page numbers does not extract the correct page number. I remember reading something about this after I'd posted, so do need to fix - in case anyone else is reading the thread for an answer.

[Frosty]

You need to use the VBA tags correctly to have it show up right...

Can you clean up the code and re-post? What I see is not read-able.

[rtwwpad]

Apologies, I need 5 posts to enable links in posts, which would assist as its a copy of the code from top hit on google. I will look at the VBA tags again

[rtwwpad]

Test

Public Sub ExtractCommentsToNewDoc()

'Macro created 2007 by Lene Fredborg, DocTools
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata

'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================

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.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=nCount + 1, _
NumColumns:=4)
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 = "Arial"
.Font.Size = 10
.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(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 25
.Columns(3).PreferredWidth = 50
.Columns(4).PreferredWidth = 20
.Rows(1).HeadingFormat = True
End With

'Insert table headings
With oTable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
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
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

[rtwwpad]

There is a technet article on why the page number may not work, I've tried all the workarounds, but now I need to try and do a recode of that functionality as well - as the formatting marks, end of document and print preview kludge fixes it recommends don't work

when you run it using Word 2010 on Windows 7, the page numbers are incorrect. i.e. the first comment is made on page 25, it says page 25 on the screen, it prints out as page 25 on the printer, but the macro says page 40.

[rtwwpad]

http://support.microsoft.com/kb/274003/EN-US - i am using word 2010 on windows 7

[Frosty]

the VBA tags make the code more easily readable by automatically using indents. It is both a button, or you can just use open brackets and close brackets such that... "[ VBA ]" and "[ / VBA ]" (without all the spaces)... here is your code more readable. Thanks for putting in the line breaks.


Public Sub ExtractCommentsToNewDoc()

'Macro created 2007 by Lene Fredborg, DocTools
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata

'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================

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.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 4-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
numrows:=nCount + 1, _
NumColumns:=4)
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 = "Arial"
.Font.Size = 10
.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(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 25
.Columns(3).PreferredWidth = 50
.Columns(4).PreferredWidth = 20
.Rows(1).HeadingFormat = True
End With

'Insert table headings
With oTable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
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
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

[Frosty]

Now... on to your real questions:
1. How to insert an additional column. I think if you look over the code, the comments clearly say where the table is created. And it is a 4 column table. So change that number to a 5. Since everything is explicit, you may need to adjust the individual widths in the other code.
2. How to get the data you want into that column ... I don't know. It depends on how your document is constructed. If that information is not contained in the comment, then you have to grab it in another way. You will need to post a sample document (which you should be able to do now). It doesn't need to be long, but it does need to be formatted in the same manner that the documents you want to run the code on are formatted.
3. How to get accurate page numbers. This topic comes up all the time. The answer is not easy. Can you do some searches on this forum about it, and then list out the things you've tried (as well as any adjustments you make to the above code).

From there, I think you should be able to get the help you need... but the answer is not ready-made, you'll need to do some of the legwork: 1) try to understand the code you posted somewhat, it is well commented, 2) create a sample document with no sensitive data and 3) do some searches on the concept of pages in Word. There are a lot of posts in this forum on this topic. Then give code snippets of what you have tried. Saying you've tried "everything" isn't enough. Be prepared for disappointment on this, however, since accurate page counts are devlishly difficult to get...since they are only ever *truly* determined when you print the document out. Everything else is simply a best guess by the various approaches via code without printing it out (although some "guesses" are better than others).

Hope this points you in the right direction.

[rtwwpad]

Hi Frosty,

Thanks for the response


Now... on to your real questions:
1. How to insert an additional column. I think if you look over the code, the comments clearly say where the table is created. And it is a 4 column table. So change that number to a 5. Since everything is explicit, you may need to adjust the individual widths in the other code.


Yes, sorry I have read and understand the code written and have improved it to be an 8 col table with some auto-text, colour coding of header rows and cols (last two) in the new doc - sorry I didnt make it clear that I understood what I was posting up, as it is perfectly well commented by the original author - the page numbers were a red herring


2. How to get the data you want into that column ... I don't know. It depends on how your document is constructed. If that information is not contained in the comment, then you have to grab it in another way. You will need to post a sample document (which you should be able to do now). It doesn't need to be long, but it does need to be formatted in the same manner that the documents you want to run the code on are formatted.

Yes, still really bugging me this one. Its not in the comment.


3. How to get accurate page numbers. This topic comes up all the time. The answer is not easy. Can you do some searches on this forum about it, and then list out the things you've tried (as well as any adjustments you make to the above code).
Oh, yes, I've spent about 7 hours bouncing through old archive threads here there and everywhere including this site (steiner and others). I've been over to msdn, technet and read their stuff. But hey I found the answer in the end through good old fashioned experimentation. The code does return accurate page numbers. However the page numbers it returns are accurate only if you have the entire view changes selected, so everything - ink, comments, deletions etc. has to be ticked and visible.

<snip>
So page count sorted :beerchug:and recorded answer for those like me who find it later. Now back to the section headings (which aren't really sections as they are just styled text really). Still banging my head against this one.:banghead:

[rtwwpad]

Interestingly as a side note, if you replace wdActiveEndPageNumber with wdRefTypeHeading it seems to return the page number as well. I thought it might have something stored in a buffer but when I commented out the Cells(2) code, it still worked.

Which is a shame as I hoped that that command would find the section for me, but it seems to identify a comment as a reference type maybe?

[Frosty]

The accuracy of the page numbers comes and goes, depending on how a document is constructed. However, if you've solved that issue for your documents, then we don't need to address it.

For your open question: you will need to post a sample document. There are lots of ways to get the info you need, but I can't tell you all of them. I need to see a document sample in order to tell you which is appropriate.

You should also probably post the code you are working on (i.e., the code you've modified, rather than the code you started with), as that will also give some insight into how you are progressing for anyone who happens on to this thread.

You should probably stop using the word section, since that has meaning-- and not the meaning you mean. You're talking about (I believe) text or numbering applied to the paragraph in which a comment is applied. It's probably trivial to get the information you want, but I can't tell you without a sample document or a better description than what you've provided. In the context of discussing VBA and word document construction, the term "section" means an actual Section of the document (defined by section breaks).

You should be able to post attachments after 5 posts, so that's the next thing for you to do in order for someone on this forum to help.

[Frosty]

Oh, and I'm not sure what you mean by "wdRefTypeHeading" -- that's not a valid enumeration for the information object, at least in my version of Word (which is Word 2010, and supposedly the same as yours).

The .Information object is useful, and works off of ranges and selections... you may have gotten something else useful from wdActiveEndAdjustedPageNumber.... but again, it all depends on the scenario. Your description of inaccurate page numbers until you show all tracked changes suggests that you might have been having a bad interaction between whether you're viewing tracked changes but not printing them out. Word may very well get confused when attempting to do page counts in that situation. I'm just adding the above for your own understanding.

[Frosty]

As a general note... the .Scope property of the comment gives the range spanned by the comment. If you don't have comments spanning multiple paragraphs, you may very well be able to get information about the paragraph the comment is in by examining the .Scope object more closely.

MsgBox oDoc.Comments(n).Scope.Paragraphs(1).Style
in the same area where you're putting the comment info into the table may be a start. But I think you probably need the numbering or the text of the paragraph.. which could be ... oDoc.Comments(n).Scope.Paragraphs(1).Range.Text or oDoc.Comments(n).Scope.Paragraphs(1).Range.ListFormat.ListString
or a variety of other things.

[rtwwpad]

Public Sub ExtractCommentsToNewDoc()

'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com (http://www.thedoctools.com)
'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata

'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'amended for by Phil Thomas May 2012
'=========================

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 = True
'Create a new document for the comments, base on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 8-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
NumRows:=nCount + 1, _
NumColumns:=8)
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 = "Arial"
.Font.Size = 10
.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
.AllowAutoFit = False
.Style = "Table Grid"
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 5
.Columns(3).PreferredWidth = 5
.Columns(4).PreferredWidth = 20
.Columns(5).PreferredWidth = 20
.Columns(6).PreferredWidth = 10
.Columns(7).PreferredWidth = 15
.Columns(7).Shading.BackgroundPatternColor = -570359809
.Columns(8).PreferredWidth = 20
.Columns(8).Shading.BackgroundPatternColor = -570359809
.Rows(1).HeadingFormat = True
End With

'Insert table headings
With oTable.Rows(1)
.Range.Font.Bold = True
.Shading.BackgroundPatternColor = 5296274
.Cells(1).Range.Text = "Comment"
.Cells(2).Range.Text = "Page"
.Cells(3).Range.Text = "Line on Page" ' will be replaced with sectiosn once I get them working
.Cells(4).Range.Text = "Comment scope"
.Cells(5).Range.Text = "Comment text"
.Cells(6).Range.Text = "Author"
.Cells(7).Range.Text = "Response Summary (Accept/Reject/Defer)"
.Cells(8).Range.Text = "Response to comment"
End With

'Repaginate
ActiveDocument.Repaginate

'Toggle nonprinting characters twice
ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll

ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll



'Get info from each comment from oDoc and insert in table
For n = 1 To nCount
With oTable.Rows(n + 1)
.Cells(1).Range.Text = n
'Page number
.Cells(2).Range.Text = oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
' The line number
'.Cells(3).Range.Text = oDoc.Comments(n).Scope.Information(wdFirstCharacterLineNumber)- keep for line numbers if I can't get Section headings
.Cells(3).Range.Text = oDoc.Comments(n).Scope.Paragraphs(1).Range.ListFormat.ListString
'The text marked by the comment
.Cells(4).Range.Text = oDoc.Comments(n).Scope
'The comment itself
.Cells(5).Range.Text = oDoc.Comments(n).Range.Text
'The comment author
.Cells(6).Range.Text = oDoc.Comments(n).Author
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

[rtwwpad]

File attached for running the macro against

[rtwwpad]

What the output looks like

[rtwwpad]

What I want it to look like - please note ignore the word line on page as a header, its to be changed afterwards

[Frosty]

It looks to me like the information you want is the text of the paragraph styled with Heading 1 somewhere in the document above the comment range. Is that accurate? So you have a document with

Style: Heading 1 Text: Section 1
a bunch of text, some with comments, some without, unknown number of paragraphs

Style: Heading 1 Text: Section 2
a bunch of text, some with comments, some without, unknown number of paragraphs

etc etc...

If you don't have any paragraphs styled as Heading 1 and then formatted directly to "look" like they don't have Heading 1 applied, then the following function should be helpful....

'----------------------------------------------------------------------------------------------------------
'return the text of the paragraph styled with the passed style name
'defaults to Heading 1
'NOTE: collapses the range to the END of the search range, since the search is up
'----------------------------------------------------------------------------------------------------------
Public Function fGetParaText(rngBefore As Range, _
Optional sStyleName As String = "Heading 1", _
Optional bIncludeParagraphMark As Boolean = False) As String
Dim rngSearch As Range
Dim sReturnText As String

On Error GoTo l_err
Set rngSearch = rngBefore.Duplicate
rngSearch.Collapse wdCollapseEnd
With rngSearch.Find
.Wrap = wdFindStop
'this is the key-- equivalent to looking "up"
.Forward = False
.Style = sStyleName
'if we found it, return it
If .Execute Then
sReturnText = rngSearch.Text
End If
End With

'if you don't want the paragraph mark included
If bIncludeParagraphMark = False Then
sReturnText = Replace(sReturnText, vbCr, "")
End If
l_exit:
'now return the text string
fGetParaText = sReturnText
Exit Function
l_err:
'black box- any errors, return an empty string
sReturnText = ""
Resume l_exit
End Function
How do you use it? You would insert it in this way into your existing code
... the with block where you insert text into a specific cell
.Cells(3).Range.Text = fGetParaText(oDoc.Comments(n).Scope)

There are two optional parameters, if you later decide you want to
a) search something other than Heading 1
b) wish to include the actual paragraph mark (which I doubt).

But it's useful to see how optional parameters can be used, so I thought I'd give you that flexibility of approach.

[Frosty]

Hmm, I see this approach isn't going to work for you, since you need to find whatever is closest previously-- Heading 1 or Heading 2 or Heading 3.... You should give a better sample document :)

I'll think about this-- but all for now. There's probably something simple like checking the current outline level, but I'll have to look into it.

I know enough that the concept of the above function would be useful (using the search function), but not when you need to find the nearest thing. There is a brute force way to do this (simply cycle through each previous paragraphs, see if the style matches what you care about, and then return that text), but that could be very slow on large documents.

All for now... perhaps someone else will take up the torch, but I'm done for a bit...

[Frosty]

So this intrigued me, and it doesn't appear that there is any built-in functionality for this. I often am surprised when something which seems rather logical and straightforward doesn't exist (such as having a property of a document which is built-in list of paragraphs and their outline levels, similar to the way the XRef list is built on the fly). But there isn't, in this case, that I can discover.

So here are two alternative methods for the price of one :) One is simple, and uses brute force. It simply goes backward, paragraph by paragraph, until it finds a style name which matches the select case list. And then it returns the text of that paragraph, minus the paragraph mark.

The other is much more complex, conceptually. If you are a beginner, this may not be the one to use unless you find the simple one seems slow. There is a lot of stuff going on which may be a little overwhelming to understand. But this is the way I would do it, because using the Find object to, well, find things is *always* faster ;)

Conceptually, the complex method uses a series of Find operations to build a collection of found ranges, and then tests those found ranges against the original range to check distance, and thus determine, among the found ranges, which is closest-- and thus return that text.

In all cases, although it is much more code, it would be faster. Depending on how your document is constructed, it *could* be significantly faster (if your original document with the comments has a lot of tables, looping through each paragraph can be really really slow). But it's also, as I said, considerably more complex. So, use at your own risk ;)

And lastly... you would use these at the same place I said before... in your With...End With block, by doing either
'simple method
.Cells(3).Range.Text = fGetParaTextBefore(oDoc.Comments(n).Scope)
'complex method
.Cells(3).Range.Text = fGetNearestParaTextStyledIn(oDoc.Comments(n).Scope)

Here you go... good luck.

- Frosty

'----------------------------------------------------------------------------------------------------------
' SIMPLE METHOD:
' A simpler to understand method, but uses brute force, and thus may become slow on larger documents
'----------------------------------------------------------------------------------------------------------
Public Function fGetParaTextBefore(rngBefore As Range)
Dim oPara As Paragraph
Dim sReturn As String

On Error GoTo l_err
Set oPara = rngBefore.Paragraphs(1)
'go back, paragraph by paragraph...
Do Until oPara.Previous Is Nothing

Set oPara = oPara.Previous
Select Case oPara.Style
Case "Heading 1", "Heading 2", "Heading 3"
'we found one with the right style
Exit Do
Case Else
'keep looking!
End Select
'make sure we don't reach the top of the document
Loop

'get the text
sReturn = oPara.Range.Text

'and you probably don't want the paragraph mark
sReturn = Replace(sReturn, vbCr, "")

l_exit:
fGetParaTextBefore = sReturn
Exit Function
l_err:
sReturn = ""
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------------------
' COMPLEX METHOD:
' Uses the Find object (which is always faster) to search an array of style names
' and return the text of the paragraph nearest to the original range
'----------------------------------------------------------------------------------------------------------
Public Function fGetNearestParaTextStyledIn(Optional rngOriginal As Range, _
Optional sStyleNames As String = "Heading 1|Heading 2|Heading 3", _
Optional bLookDown As Boolean = False, _
Optional bIncludeParagraphMark As Boolean = False) As String

Dim oDoc As Document
Dim aryStyleNames() As String
Dim colFoundRanges As Collection
Dim rngReturn As Range
Dim i As Integer
Dim sReturnText As String
Dim lDistance As Long

On Error GoTo l_err
'set a default if we didn't pass it
If rngOriginal Is Nothing Then
Set rngOriginal = Selection.Range.Duplicate
End If

'create a new instance of a collection
Set colFoundRanges = New Collection

'get our array of style names to look for
aryStyleNames = Split(sStyleNames, "|")

'loop through the array
For i = 0 To UBound(aryStyleNames)
'if you wanted to add additional styles, you could change the optional parameter, or
'pass in different values
Set rngReturn = fGetNearestParaRange(rngOriginal.Duplicate, aryStyleNames(i), bLookDown)
'if we found it in the search direction
If Not rngReturn Is Nothing Then
'then add it to the collection
colFoundRanges.Add rngReturn
End If
Next

'if we found anything in our collection, then we can go through it,
'and see which range is closest to our original range, depending on our search direction
If colFoundRanges.Count > 0 Then
'start with an initial return
Set rngReturn = colFoundRanges(1)
'and an initial distance value as an absolute number
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
'then go through the rest of them, and return the one with the lowest distance between
For i = 2 To colFoundRanges.Count
If lDistance > Abs(rngOriginal.Start - colFoundRanges(i).Start) Then
'set a new range
Set rngReturn = colFoundRanges(i)
'and a new distance test
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
End If
Next

'now get the text we're going to return
sReturnText = rngReturn.Text
'and whether to include the paragraph mark
If bIncludeParagraphMark = False Then
sReturnText = Replace(sReturnText, vbCr, "")
End If
End If


l_exit:
fGetNearestParaTextStyledIn = sReturnText
Exit Function
l_err:
'black box, so that any errors return an empty string
sReturnText = ""
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------------------
'return the nearest paragraph range styled
'defaults to Heading 1
'NOTE: if searching forward, starts searching from the *beginning* of the passed range
' if searching backward, starts searching from the *end* of the passed range
'----------------------------------------------------------------------------------------------------------
Public Function fGetNearestParaRange(rngWhere As Range, _
Optional sStyleName As String = "Heading 1", _
Optional bSearchForward As Boolean = False) As Range
Dim rngSearch As Range

On Error GoTo l_err
Set rngSearch = rngWhere.Duplicate
'if searching down, then start at the beginning of our search range
If bSearchForward Then
rngSearch.Collapse wdCollapseStart
'otherwise, search from the end
Else
rngSearch.Collapse wdCollapseEnd
End If

'find the range
With rngSearch.Find
.Wrap = wdFindStop
.Forward = bSearchForward
.Style = sStyleName
'if we found it, return it
If .Execute Then
Set fGetNearestParaRange = rngSearch
Else
Set fGetNearestParaRange = Nothing
End If
End With

l_exit:
Exit Function
l_err:
'black box- any errors, return nothing
Set rngSearch = Nothing
Resume l_exit
End Function

[rtwwpad]

You sound like me yesterday - it must be possible, surely they wouldnt :)

Many thanks, that code works great and I think I can follow most of it.

Phil

[rtwwpad]

Hi Frosty

So that code works great, but I've just encountered another formatted document type which is also used and while the code extracts the heading of the subsection, they have essentially created a list style and then linked the list style to the various headings, so they get a numbered approach 1, 1.1 etc.

Is it possible to extract the numbers for each part of the document as well?

I have attached a new sample document to illustrate the point

I've got to review a bunch of docs today so will work on it over the weekend, but I thought I would be cheeky and ask in case you said oh yes just change X to Y in the code.

[rtwwpad]

I was reading your code and hoped it was returned by setting bincludeparagrah mark to true, but it isn't unless I need to add a piece of text onto SReturnText.

I am looking at http://msdn.microsoft.com/en-us/library/microsoft.office.interop.word.range_properties to see if there is a property which we would have found with the recursive search in the document, but its slow going trying them out and reading them as well to be honest - sometimes hyperlinked documents don't rule :)

I'm going to have a play with it all and any answer post back here

[rtwwpad]

That was quick and easy

Simply use the .ListFormat.ListString part of the range and then you can concatenate the two together and return section numbering and section title

Thanks to this page for answer

http://word.mvps.org/faqs/numbering/liststring.htm

Frosty still rules for the search code though :beerchug:

[Frosty]

Umm... Yes. ListString and prepending it on to the return string is the way to go :) glad to be of service! ;)

Also, since others can benefit from your discoveries, it's nice to post the lines of code you modified to get what you wanted, rather than just the links to the research. That way everyone benefits... Including you, if you made a mistake with your modification.

I'm glad you figured it out on your own, that's fantastic.

[rtwwpad]

Finished Code

Public Sub ExtractCommentsToNewDoc()

'Original source Macro created 2007 by Lene Fredborg, DocTools
'amended by Phil Thomas May 2012 www.grosvenorsc.com (http://www.grosvenorsc.com)
'with help from Frosty at VBAExpress.com



'The macro creates a new document
'and extracts all comments from the active document
'incl. metadata

'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
'Setup all the variables
Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim nCount As Long
Dim n As Long
Dim Title As String

'Setup intital values
Title = "Extract All Comments to New Document"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count

'Check if document has any comments in it and if it does, then check this is what the user wants to do
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

'Turned on as recommendation from MSDN Technet article
Application.ScreenUpdating = True
'Create a new document for the comments, based on Normal.dot
Set oNewDoc = Documents.Add
'Set to landscape
oNewDoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 10-column table for the comments
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
NumRows:=nCount + 1, _
NumColumns:=9)
End With

'Insert info in header - change date format as you wish
oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Document Review Record - " & "Comments extracted from: " & oDoc.Name & vbCr & _
"Created by: " & Application.UserName & _
" Creation date: " & Format(Date, "MMMM d, yyyy") & _
" - All page and line numbers are with Final: Show Markup turned on"
'insert page number into footer
oNewDoc.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight


'Adjust the Normal style and Header style
With oNewDoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 8
.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
.AllowAutoFit = False
.Style = "Table Grid"
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 20
.Columns(3).PreferredWidth = 5
.Columns(4).PreferredWidth = 5
.Columns(5).PreferredWidth = 20
.Columns(6).PreferredWidth = 20
.Columns(7).PreferredWidth = 10
.Columns(8).PreferredWidth = 15
.Columns(8).Shading.BackgroundPatternColor = -570359809
.Columns(9).PreferredWidth = 20
.Columns(9).Shading.BackgroundPatternColor = -570359809
.Rows(1).HeadingFormat = True
End With

'Insert table headings
With oTable.Rows(1)
.Range.Font.Bold = True
.Shading.BackgroundPatternColor = 5296274
.Cells(1).Range.Text = "Comment"
.Cells(2).Range.Text = "Section Heading"
.Cells(3).Range.Text = "Page"
.Cells(4).Range.Text = "Line on Page"
.Cells(5).Range.Text = "Comment scope"
.Cells(6).Range.Text = "Comment text"
.Cells(7).Range.Text = "Author"
.Cells(8).Range.Text = "Response Summary (Accept/ Reject/ Defer)"
.Cells(9).Range.Text = "Response to comment"
End With

'Repaginate - Start MSDN bug fix on Knowledgebase article
ActiveDocument.Repaginate

'Toggle nonprinting characters twice
ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll

ActiveWindow.ActivePane.View.ShowAll = Not _
ActiveWindow.ActivePane.View.ShowAll
'End MSDN KB code


'Get info from each comment from oDoc and insert in table, no way to currently insert Criticality of comment.
'Suggest either done afterwards or simply include C,S,M in the start of each comment and remove Col 8
For n = 1 To nCount
With oTable.Rows(n + 1)
.Cells(1).Range.Text = n
'call function to get section heading
.Cells(2).Range.Text = fGetNearestParaTextStyledIn(oDoc.Comments(n).Scope)
'Page number
.Cells(3).Range.Text = oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
' The line number
.Cells(4).Range.Text = oDoc.Comments(n).Scope.Information(wdFirstCharacterLineNumber)
'The text marked by the comment
.Cells(5).Range.Text = oDoc.Comments(n).Scope
'The comment itself
.Cells(6).Range.Text = oDoc.Comments(n).Range.Text
'The comment author
.Cells(7).Range.Text = oDoc.Comments(n).Author
End With
Next n

Application.ScreenUpdating = True
Application.ScreenRefresh

'Tell them its finished
oNewDoc.Activate
MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title

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

End Sub


'----------------------------------------------------------------------------------------------------------
' COMPLEX SEARCH METHOD:
' Uses the Find object (which is always faster) to search an array of style names
' and return the text of the paragraph nearest to the original range
'----------------------------------------------------------------------------------------------------------
Public Function fGetNearestParaTextStyledIn(Optional rngOriginal As Range, _
Optional sStyleNames As String = "Heading 1|Heading 2|Heading 3", _
Optional bLookDown As Boolean = False, _
Optional bIncludeParagraphMark As Boolean = False) As String

Dim oDoc As Document
Dim aryStyleNames() As String
Dim colFoundRanges As Collection
Dim rngReturn As Range
Dim i As Integer
Dim sReturnText As String
Dim s1ReturnText As String
Dim s2ReturnText As String
Dim lDistance As Long

On Error GoTo l_err
'set a default if we didn't pass it
If rngOriginal Is Nothing Then
Set rngOriginal = Selection.Range.Duplicate
End If

'create a new instance of a collection
Set colFoundRanges = New Collection

'get our array of style names to look for
aryStyleNames = Split(sStyleNames, "|")

'loop through the array
For i = 0 To UBound(aryStyleNames)
'if you wanted to add additional styles, you could change the optional parameter, or
'pass in different values
Set rngReturn = fGetNearestParaRange(rngOriginal.Duplicate, aryStyleNames(i), bLookDown)
'if we found it in the search direction
If Not rngReturn Is Nothing Then
'then add it to the collection
colFoundRanges.Add rngReturn
End If
Next

'if we found anything in our collection, then we can go through it,
'and see which range is closest to our original range, depending on our search direction
If colFoundRanges.Count > 0 Then
'start with an initial return
Set rngReturn = colFoundRanges(1)
'and an initial distance value as an absolute number
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
'then go through the rest of them, and return the one with the lowest distance between
For i = 2 To colFoundRanges.Count
If lDistance > Abs(rngOriginal.Start - colFoundRanges(i).Start) Then
'set a new range
Set rngReturn = colFoundRanges(i)
'and a new distance test
lDistance = Abs(rngOriginal.Start - rngReturn.Start)
End If
Next

'now get the text we're going to return
s1ReturnText = rngReturn.ListFormat.ListString
s2ReturnText = rngReturn.Text
sReturnText = s1ReturnText & " - " & s2ReturnText
'and whether to include the paragraph mark
If bIncludeParagraphMark = False Then
sReturnText = Replace(sReturnText, vbCr, "")
End If
End If


l_exit:
fGetNearestParaTextStyledIn = sReturnText
Exit Function
l_err:
'black box, so that any errors return an empty string
sReturnText = ""
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------------------
'return the nearest paragraph range styled
'defaults to Heading 1
'NOTE: if searching forward, starts searching from the *beginning* of the passed range
' if searching backward, starts searching from the *end* of the passed range
'----------------------------------------------------------------------------------------------------------
Public Function fGetNearestParaRange(rngWhere As Range, _
Optional sStyleName As String = "Heading 1", _
Optional bSearchForward As Boolean = False) As Range
Dim rngSearch As Range

On Error GoTo l_err
Set rngSearch = rngWhere.Duplicate
'if searching down, then start at the beginning of our search range
If bSearchForward Then
rngSearch.Collapse wdCollapseStart
'otherwise, search from the end
Else
rngSearch.Collapse wdCollapseEnd
End If

'find the range
With rngSearch.Find
.Wrap = wdFindStop
.Forward = bSearchForward
.Style = sStyleName
'if we found it, return it
If .Execute Then
Set fGetNearestParaRange = rngSearch
Else
Set fGetNearestParaRange = Nothing
End If
End With

l_exit:
Exit Function
l_err:
'black box- any errors, return nothing
Set rngSearch = Nothing
Resume l_exit
End Function

[Frosty]

Looks good. Just a quick comment-- you don't necessarily need 2 new variables to do what you wanted to do. You could easily have used...
sReturnText = rngReturn.ListFormat.ListString & " - " & rngReturn.Text

However, you may want to do a little customization in order to handle both scenarios, something like?

If rngReturn.ListFormat.ListString = "" Then
sReturnText = rngReturn.Text
Else
sReturnText = rngReturn.ListFormat.ListString & " - " & rngReturn.Text
End If

That would cover both scenarios, without having to change the code for two different document types.

[bbqq021]

Hello, i am new to this forum and have been struggling on my own for a while with WORD VBA. I consider myself a newbie with regard to Word VBA, however i do have limited experience in Excel.

I am trying to create a macro that does something very similar to what RT-PAD was working on with an additional field or column for track changes. I have asked my colleagues that when they review word documents they should make the change (addition or deletion) and the first line of the track change, they should highlight and make a comment, include an explanation of why they are proposing the change.

My progress so far is to be able to create a table with the comments above and the track changes below, it searches for comments then once n count is reached it starts on the track changes. Not very helpful when you are reviewing each change line by line. I then tried exporting this to excel where i could sort on the page number then line number and then re-import to word (i was desperate) however i discovered the various limitations of excel with regard to character limits.

I understand the revision collections and comment collections are treated separately and having a nested loop with the comment extraction inside the revision extraction may not work.

Just to be clear I want my table to sequentially list the track changes and comments through a document (sorted on page number and line number). For lines of the document with track changes AND comments I want them both to be printed in a single row. Where comments or track changes appear only then blank cells can be left.

Can someone give me an idea of the direction I need to be going to make this work? I will give it a go and then probably have to post the code for some more help.

Thanks in advance

Will

[bbqq021]

So i have been doing a bit of surfing and found this advice from Jay Freedman.

So i understand for each comment or revision i will have to keep track of the position within the document using range.start and range.end.

This is where my understandind stops. The syntax required for this is a little beyond me, can anyone give me further pointers?

Incedentally, there may be some short notes for me just to boost my post count.... I hear you cannot attach code until you have 5 posts?



As far as VBA is concerned, comments are completely separate from tracked
changes. Just as the tracked changes are in the ActiveDocument.Revisions
collection, the comments are in the ActiveDocument.Comments collection, and
they have nothing to do with each other.

You would need a separate part of your macro devoted to handling comments,
with a separate loop

Dim oCmt As Comment

For Each oCmt In ActiveDocument.Comments
' extract the properties of oCmt here, like this...
.Cells(2).Range.Text = oCmt.Author
.Cells(3).Range.Text = oCmt.Range.Text
Next

This loop cannot be intermixed with the loop that handles the Revisions
collection -- they must be separate loops. If you want the extracted table
to put the comments in between the tracked changes in the same order they
occur in the original document, you'll have to do that separately by keeping
track of the .Range.Start and .Range.End values (which are, respectively,
the number of characters from the beginning of the document to the start and
end of the Range) and inserting or moving table rows to match.

[bbqq021]

So i have been going around in circles a little with the loops for the comments and revision inside each other. I couldn't figure out how to do this and so in the end i did away with the loops in favour of the GOTO command....... is this realistic?

My If statement syntax is not working and so i cannot tell if the entire code is working. As you can tell i am clutching at straws a little. here is my code, if anyone can help it would be appreciated.

I only expect this code to print the comments and revisions on the order they appear in the oDoc. I haven't thought about the problem should the comments and revisions appear on the same line. One step at a time.


Set oNewDoc = ActiveDocument
Set oDoc = Documents.Add(Visible:=True)
Set oRange = oDoc.Range(0, 0)
Set oTable = oDoc.Tables.Add(Range:=Selection.Range, numrows:=cCount + rCount + 1, NumColumns:=13)

c = 1

label1:

If oDoc.Comments(c).Scope.Information(wdFirstCharacterColumnNumber) < _
oDoc.Revision(r).Range.Information(wdFirstCharacterColumnNumber) Then


'Index Number
oTable.Cell(c + r, 1).Range.Text = c
'Page number
oTable.Cell(c + r, 2).Range.Text = oDoc.Comments(c).Scope.Information(wdActiveEndPageNumber)
'The line number
oTable.Cell(c + r, 3).Range.Text = oDoc.Comments(c).Scope.Information(wdFirstCharacterLineNumber)
'call function to get section heading
oTable.Cell(c + r, 4).Range.Text = fGetNearestParaTextStyledIn(oDoc.Comments(c).Scope)

'The text marked by the comment
oTable.Cell(c + r, 7).Range.Text = oDoc.Comments(c).Scope
'The comment itself
oTable.Cell(c + r, 8).Range.Text = oDoc.Comments(c).Range.Text
'The comment author
oTable.Cell(c + r, 9).Range.Text = oDoc.Comments(c).Author

c = c + 1

GoTo label1:

Else

r = 1

'Type of revision
If oRevision(r).Type = wdRevisionInsert Then
oTable.Cell(c + r, 5).Range.Text = "Inserted"
Else
oTable.Cell(c + r, 5).Range.Text = "Deleted"
End If

'inserts the actual track change itself
oTable.Cell(c + r, 6).Range.Text = oRevision.Range.Text = strText

r = r + 1

GoTo label1:

End If

[bbqq021]

I have moved on a little from my last post and solved my problem in a round about way.

Now moving onto a yet simpler problem.

I am using wdFirstCharacterLineNumber and wdActiveEndPageNumber to identify the position of comments and revisions, return them, then selection.sort to sort all the line items into order. The problem is, when a comment highlights text which laps over onto the second page, the page number returned is that at the end of the range whilst the revision is that of the first character.

Occasionally this throws out my numbering.

I don't know the syntax but what i want to do it:

If (comment)range.start.pagenumber = range.end.pagenumber then
do normal code
Else
return the page number of the start of the range.

alternatively i would like

Scope.Information(wdActiveEndPageNumber) to return the START page number instead of END. Can you do this using 'adjust'?

[Frosty]

bbqq021 -- you should really start new posts with new questions, rather than ressurect old ones. If an old post contains information, then provide a link to that post in your new post.

In addition to being good forum etiquette (hijacking threads which have been asked and answered is generally not a great approach), you may find that you have more people trying to help.

I'm sure there is a way to do what you want to do... you probably just need to collapse the range before you test the .Information property of it.

However, I would suggest creating a new post to get a complete answer. I've been very inactive in the last few months because I've been swamped with work.

You've got a good chance of getting your question answered by another currently more active poster.

Cheers.