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 oneOne 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
[vba]
'----------------------------------------------------------------------------------------------------------
' 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
[/vba]
Reply With Quote
