' Macro to collect comments from a Word Document
' for HL7 Ballots
' Revise the document with Revision Tracking on
' For each revision, add a comment
' Run the GetComments macro (Turn Developer Mode On)
' And your comments will be inserted at the end
' of the document. You can format that as a table
' using Convert Text to Table (Use Tabs as Cell Delimiters)
Dim allRevs As Collection
Sub GetComments()
'
' GetComments Macro
'
'
' Show view in original mode to get correct page numbers
' Dim viewMode As Integer
' viewMode = ActiveWindow.View.RevisionsView
' ActiveWindow.View.RevisionsView = wdRevisionsViewOriginal
Dim d As Document
Set d = ActiveDocument ' Use the active document to collect comments
Dim c As Comment
Dim r As Collection
' set up a new collection of revisions to speed up processing
Set allRevs = New Collection
For Each rev In d.Revisions
allRevs.Add rev
Next rev
Dim comments As String ' Where we put the end result
T = Chr$(9) ' Used to delimite fields in the result
Set r = getSortedComments(d) ' Get the comments sorted by document position
' for each comment in the document
For Each c In r
Dim originalText As String ' The original, unedited Text
Dim newText As String ' The revised Text
Dim commentText As String ' The user's comment
Dim revs As Collection ' The revisions bounded by the comment
Set revs = getRevisions(c.Scope)
originalText = getRevisionText(c.Scope, revs, wdRevisionInsert) ' Get the Text with insertions removed
newText = getRevisionText(c.Scope, revs, wdRevisionDelete) ' Get the Text with deletions removed
' If there were no Text changes, don't provide a "revised Text" column
If newText = originalText Then
newText = ""
End If
' Get the heading in the document where the comment appears
Dim heading As Paragraph
Set heading = getHeadingParagraph(c.Scope)
Dim headingNumber As String
Dim headingText As String
' Select the heading number for the paragraph that is the heading
If Not (heading Is Nothing) Then
headingText = Left(heading.Range.text, Len(heading.Range.text) - 1)
heading.SelectNumber
headingNumber = Selection.Range.text
End If
commentText = c.Range.text
' Split the vote from the comment Text
pos = InStr(commentText, ":")
If pos <> 0 Then
vote = Left(commentText, pos - 1)
commentText = Right(commentText, Len(commentText) - (pos + 1))
End If
Dim pageNumber As String
pageNumber = c.Scope.Information(wdActiveEndAdjustedPageNumber)
' Add the comment to the string
comments = comments + headingNumber + T + headingText + T + vote + T + originalText + T + newText + T + commentText + Chr$(13) + Chr$(10)
Next c
' Go to the end of the document
Dim rngEnd As Range
Set rngEnd = d.GoTo(what:=wdGoToLine, which:=wdGoToLast)
rngEnd.Select
' Write the comment Text
Application.Selection.text = comments
' Reset view mode to original state
' ActiveWindow.View.RevisionsView = viewMode
End Sub
' Get comments sorted by position in the document
Function getSortedComments(d As Document) As Collection
Dim c2 As Collection ' Create a new collection to be sorted
Set c2 = New Collection
Dim i, j As Integer ' looping variables for the sort
For i = 1 To d.comments.Count ' populate the collection
c2.Add d.comments(i)
Next i
' Bubble Sort it. Should be fewer than 100 comments, so
' a bubble sort is fine.
For i = 1 To c2.Count - 1
For j = i + 1 To c2.Count
If c2(i).Scope.Start > c2(j).Scope.Start Then
Dim r As Range
Set r = c2(j)
Set c2(j) = c2(i)
Set c2(i) = r
End If
Next j
Next i
' Return the sorted list
Set getSortedComments = c2
End Function
' Find the revisions associated with a comment (bounded by it)
Function getRevisions(r As Range) As Collection
' Assuming there will be a small number of revisions in the document (perhaps a couple hundred)
' So we can use a dead stupid search to find the ones that match the range of the comment
Dim c As Collection
Set c = New Collection
Dim i As Integer
' This is a slow linear search, but since there should be just a couple hundred
' revisions at most, nothing more challenging need be implemented.
i = 1
While i < allRevs.Count
Dim rev As Revision
Set rev = allRevs(i)
' If you find a matching revision with a comment
If rev.Range.InRange(r) Then
' add it to the list of returned revisions
c.Add rev
' Remove it from the list of revisions to search against
allRevs.Remove i
Else
i = i + 1
End If
Wend
Set getRevisions = c
End Function
' Given a Text string in range r, revisions in collection C,
' remove the Text associated with revisionType
' When revisionType = wdRevisionInsert, this will return original Text
' When revisionType = wdRevisionDelete, this will return the new Text
Function getRevisionText(r As Range, c As Collection, revisionType As Integer) As String
Dim s As String
s = r.text
Dim rev As Revision
Dim c2 As New Collection
' It makes it easier to delete the right stuff from the string
' if we Reverse the order of changes in the collection
For i = c.Count To 1 Step -1
c2.Add c(i)
Next i
For Each rev In c2
If rev.Type = revisionType Then
' This was unwanted Text, we need to remove it from the string
TextStart = rev.Range.Start - r.Start
TextEnd = rev.Range.End - r.Start
s = Left(s, TextStart) + Mid(s, TextEnd, Len(s) - TextEnd)
End If
Next rev
getRevisionText = s
End Function
' Given a range of Text, search backwards to find the first heading paragraph
Function getHeadingParagraph(r As Range) As Paragraph
Dim p As Paragraph
Set p = r.Paragraphs(1)
Dim s As Style
Set s = p.Style
' While the style of this paragraph does not contain the word heading
While InStr(s.NameLocal, "Heading") = 0
Set p = p.Previous ' Get previous paragraph
Set s = p.Style ' and style name
Wend
' Return the paragraph that is the heading
Set getHeadingParagraph = p
End Function
Sub Flavor()
'
' Flavor Macro
'
'
Selection.comments.Add Range:=Selection.Range
Selection.TypeText text:="Nm: Flavor vs. templateId"
End Sub
Sub Use()
'
' Flavor Macro
'
'
Selection.comments.Add Range:=Selection.Range
Selection.TypeText text:="NM: Use vocabulary required by CDA"
End Sub