I can see there's room for improvement by utilizing the .Words collection as well, but going to leave that for now.
I can see there's room for improvement by utilizing the .Words collection as well, but going to leave that for now.
Jason,
I added a Test #6 and made a few other minor changes. The rest is just style.
Works as before with the test sentences we have been using.
My grammar is not much better than my spelling. Test #6 handles:
Joe shouted, “Throw me the ball!” before running over the edge of thecliff.
.... which I think should be treated a one sentence.
[VBA]Option Explicit
Private m_strFollowingText As String
Private m_strPrecedingText As String
Private m_oRngParagraph As Range
Private m_colSentencesDeduced As Collection
'************************************************************************** **********************
Public Sub BoldAFirstSentence()
If SelectASentence(1) = True Then
Selection.Font.Bold = True
End If
End Sub
'************************************************************************** **********************
'Select the sentence the cursor is currently in (or the first sentence in the selected range)
Public Sub SelectCurrentSentence()
Dim i As Long
Dim oRngDeducedSentence As Range
'Dim m_colSentences As Collection
'If not for this line, nothing will get selected if the selection spans two sentences.
Selection.Collapse wdCollapseStart
Set m_colSentencesDeduced = fGetRealSentences(Selection.Range)
i = 1
For Each oRngDeducedSentence In m_colSentencesDeduced
i = i + 1
If Selection.Range.InRange(oRngDeducedSentence) Then
Select Case True
Case oRngDeducedSentence.End = ActiveDocument.Range.End
oRngDeducedSentence.MoveEnd wdCharacter, -1
Case i > 1 And m_colSentencesDeduced.Count > 1 And oRngDeducedSentence.End = Selection.Paragraphs(1).Range.End
oRngDeducedSentence.MoveEnd wdCharacter, -1
End Select
oRngDeducedSentence.Select
Exit For
End If
Next oRngDeducedSentence
lbl_Exit:
Exit Sub
End Sub
'************************************************************************** *********************
'Target indexed sentence in first paragraph defined by the selection (See call above).
Public Function SelectASentence(Optional lngIndex As Long = 1) As Boolean
'Establish boundry.
Set m_oRngParagraph = Selection.Paragraphs(1).Range
'Get collection of "real" sentences
Set m_colSentencesDeduced = fGetRealSentences(m_oRngParagraph)
On Error Resume Next
m_colSentencesDeduced(lngIndex).Select
'If unable to select then it must not exist.
If Err.Number = 0 Then
SelectASentence = True
Else
SelectASentence = False
MsgBox "A sentence defined by the passed index " & lngIndex & " does not exist in the seleciton.", vbInformation
End If
End Function
'************************************************************************** *********************
'Creates a collection of "real" (or hopefully more realistic) sentences in the first paragraph
'of the passed range based on the built-in Sentences collection object
Public Function fGetRealSentences(oRngSelectionStart As Range) As Collection
Dim colSentences As Sentences
Dim oRngSentence As Range
Dim oRngEndMark As Range
Dim oRngSentenceDeduced As Range
'Initialize our collection variable.
Set m_colSentencesDeduced = New Collection
'Fix a boundry.
Set m_oRngParagraph = oRngSelectionStart.Paragraphs(1).Range
'Get collection of Word-Native defined sentences (a collection of ranges).
Set colSentences = m_oRngParagraph.Sentences
'Initialize our new sentence, so that it has a good start
Set oRngSentenceDeduced = colSentences(1)
'If Word returns a single sentence then a single sentence it is.
If colSentences.Count = 1 Then
m_colSentencesDeduced.Add m_oRngParagraph
Else
'Word returns multiple sentences. But is this true?
'Loop through the MS-determined "sentences" to find out.
For Each oRngSentence In colSentences
With oRngSentence.Characters.Last
Set oRngEndMark = .Previous
'If out of bounds, then adjust backwards.
'This deals with MS defaulting to including blank paragraphs in the concept of a "Sentence"
If .InRange(m_oRngParagraph) = False Then
Do Until oRngEndMark <> vbCr
Set oRngEndMark = oRngEndMark.Previous
Loop
End If
'Now see if our MS-identified sentence ender is "really" a sentence ender.
'If it is then add to range.
If fIsSentenceEnder(oRngEndMark) Then
'Do we need to adjust this forward or backward?
oRngSentenceDeduced.End = oRngEndMark.End
'Get rid of preceeding whitespaces before adding to our collection of sentences
Do Until fIsWhiteSpace(oRngSentenceDeduced.Characters.First) = False
oRngSentenceDeduced.MoveStart wdCharacter, 1
Loop
'Should we include trailing whitespaces in our sentence definition (MS does)
Do
If oRngSentenceDeduced.Characters.Last <> vbCr Then
oRngSentenceDeduced.MoveEnd wdCharacter, 1
Else
Exit Do
End If
Loop Until fIsWhiteSpace(oRngSentenceDeduced.Characters.Last.Next) = False
'Add deduced sentence to collection.
m_colSentencesDeduced.Add oRngSentenceDeduced.Duplicate
'Redefine start.
oRngSentenceDeduced.Collapse wdCollapseEnd
End If
End With
Next oRngSentence
End If
'Return the collection
Set fGetRealSentences = m_colSentencesDeduced
lbl_Exit:
End Function
'************************************************************************** *********************
'Validate sentence ender.
Public Function fIsSentenceEnder(oRngEndMarkPassed As Range) As Boolean
Dim i As Long
Dim oRngParagraph As Range
Dim strEndings_Not As String
Dim strEndings_Maybe As String
'Preliminary list. Adjust as required - utilize a Split on the delimiter "|" later.
strEndings_Not = "Mr|Mrs|Ms|Dr"
strEndings_Maybe = "Jr|Esq|MD"
'Define parent paragraph (which is the absolute bound).
Set oRngParagraph = oRngEndMarkPassed.Paragraphs.First.Range
'Test #1 - If we're at the end of our paragraph, it's a sentence ender
If oRngEndMarkPassed.End = oRngEndMarkPassed.Paragraphs(1).Range.End Then
fIsSentenceEnder = True
GoTo lbl_Exit
End If
'Determine what comes before and after ending mark.
m_strPrecedingText = fGetText(oRngEndMarkPassed, False)
m_strFollowingText = fGetText(oRngEndMarkPassed, True)
'Test #2 - If nothing follows then it must be the end of a sentence. (Jason this might be redundant??)
If m_strFollowingText = "" Then
fIsSentenceEnder = True
GoTo lbl_Exit
End If
'Test #3 (require at least one following "white space" character
If fIsWhiteSpace(oRngEndMarkPassed.Next) = False Then
fIsSentenceEnder = False
GoTo lbl_Exit
Else
'If it is followed by more multiple whitespace characters (e.g., two spaces) the assume a sentence ender.
If fIsWhiteSpace(oRngEndMarkPassed.Next.Next) Then
fIsSentenceEnder = True
GoTo lbl_Exit
End If
End If
'Test #4 (Mr. John Smith)
'Test using array of definite non-sentence ending periods (add to this as needed)
If fPhraseMatch(strEndings_Not, oRngEndMarkPassed) = 1 Then
fIsSentenceEnder = False
GoTo lbl_Exit
End If
'Test #5 (John Smith Esq.)
'Similar test, although these are the "maybes", which necessitate an extra check.
Select Case fPhraseMatch(strEndings_Maybe, oRngEndMarkPassed, True)
Case 1
fIsSentenceEnder = True
GoTo lbl_Exit
Case 2
fIsSentenceEnder = False
GoTo lbl_Exit
Case Else
'Keep evaluating.
End Select
'Test #5 ( A.) -- a single capital letter preceded by white space, assume an initial?
If fIsWhiteSpace(oRngEndMarkPassed.Previous.Previous) Then
If oRngEndMarkPassed.Previous.Text Like "[A-Z]" Then
fIsSentenceEnder = False
GoTo lbl_Exit
End If
End If
'Test #6 - Does the following text begin a natural sentence?
'(1) Begin a paragraph.
'(2) Begin with a capital letter or number.
'(3) Begin with a quotation mark followed by a capital letter or number.
Select Case Asc(Left(m_strFollowingText, 1))
Case 13
Case 11
Select Case Asc(Mid(m_strFollowingText, 2, 1))
Case 48 To 57, 65 To 90
Case 34, 147, 148
Select Case Asc(Mid(m_strFollowingText, 3, 1))
Case 48 To 57, 65 To 90
Case Else
fIsSentenceEnder = False
GoTo lbl_Exit
End Select
Case Else
fIsSentenceEnder = False
GoTo lbl_Exit
End Select
Case 48 To 57, 65 To 90
Case 34, 147, 148
Select Case Asc(Mid(m_strFollowingText, 2, 1))
Case 48 To 57, 65 To 90
Case Else
fIsSentenceEnder = False
GoTo lbl_Exit
End Select
Case Else
fIsSentenceEnder = False
GoTo lbl_Exit
End Select
'Unless there are more test discovered later then assume yes.
fIsSentenceEnder = True
lbl_Exit:
Exit Function
End Function
'************************************************************************** **************************
'Check the passed character to see if it is a "white space" character.
Public Function fIsWhiteSpace(oRngCharacter As Range) As Boolean
'If it doesn't exist, then it isn't whitespace!
If Not oRngCharacter Is Nothing Then
Select Case Asc(oRngCharacter.Text)
Case 9, 32, 160, 13, 11
fIsWhiteSpace = True
Case Else
fIsWhiteSpace = False
End Select
End If
lbl_Exit:
Exit Function
End Function
'************************************************************************** **************************
'Check to the passed in phrase against any matching phrases.
'should this be case sensitive or not?
'Returns 1 if found a match, and a sentence-ending period
'Returns 2 if found a match, and not a sentence-ending period (based on upper case alpha letter)
'returns 0 if no match found
Public Function fPhraseMatch(sAbbreviations As String, oRngEndMarkPassed As Range, _
Optional bMightBeEnders As Boolean = False) As Long
Dim arrAbbreviations() As String
Dim i As Long
Dim j As Long
arrAbbreviations = Split(sAbbreviations, "|")
For i = 0 To UBound(arrAbbreviations)
'Match so far...
If m_strPrecedingText = arrAbbreviations(i) Then
'If no further tests, have a match.
If bMightBeEnders = False Then
fPhraseMatch = 1
Else
'Check rest of maybes.
For j = 0 To UBound(arrAbbreviations)
If m_strFollowingText = arrAbbreviations(j) Then
'Match found, not a sentence ending period
fPhraseMatch = 2
GoTo lbl_Exit
End If
Next j
Select Case Asc(Left(m_strFollowingText, 1))
'New paragraph, A-Z or number.
Case 13, 48 To 57, 65 To 90
fPhraseMatch = 1
Case 34, 147, 148
Select Case Asc(Mid(m_strFollowingText, 2, 1))
Case 48 To 57, 65 To 90
fPhraseMatch = 1
Case Else
fPhraseMatch = 2
End Select
Case Else
fPhraseMatch = 2
End Select
End If
Exit For
End If
Next i
lbl_Exit:
Exit Function
End Function
'************************************************************************** *********************
'Returns text immediately following or immediately preceding the range bound by our "white space" concept
Public Function fGetText(rngWhere As Range, Optional bGetFollowing As Boolean) As String
Dim oRngWorking As Range
Dim strReturn As String
Set oRngWorking = rngWhere.Duplicate
If bGetFollowing Then
oRngWorking.Collapse wdCollapseEnd
'Avoid infinite loops.
If Not oRngWorking.Characters.Last.Next Is Nothing Then
Do Until fIsWhiteSpace(oRngWorking.Characters.Last.Next)
oRngWorking.MoveEnd wdCharacter, 1
Loop
End If
strReturn = oRngWorking.Text
Else
oRngWorking.Collapse wdCollapseStart
'Avoid infinite loops.
If Not oRngWorking.Characters.First.Previous Is Nothing Then
Do Until fIsWhiteSpace(oRngWorking.Characters.First.Previous)
oRngWorking.MoveStart wdCharacter, -1
Loop
End If
strReturn = oRngWorking.Text
End If
'Trim it, and remove the ending mark.
strReturn = Trim(strReturn)
strReturn = Replace(strReturn, ".", "")
strReturn = Replace(strReturn, "?", "")
strReturn = Replace(strReturn, "!", "")
fGetText = strReturn
lbl_Exit:
Exit Function
End Function
[/VBA]
After a good bit of back and forth between Greg and I... here's a demo template utilizing a new class for sentences.
Bernadette, this is way more than you actually asked for. However, this may provide utility for others as well.
Wow guys, thank you for the contribution...I, for one, find utility.
And here is a slightly more explanatory template, in that it has some buttons to click on the Quick Access Toolbar, as well as a demonstration of the difference between how the builtin Microsoft Sentences are defined, and how this code goes.
If anyone wants to use this, the ThisApplication isn't really necessary (as that's a separate concept Greg and I were testing)... you'd just need to import the cSentences class into your project, and then use code based on the samples in the mMain module.
Note: copying the text of the class and pasting into your own version of a cSentences class will work, except that you'll lose a hidden attribute defining default member of the class. That's a whole lot of blah blah-- basically, import (or drag copy) the cSentences class module from this project to yours if you want to use it.
Greg Maxey pointed out a flaw in the above project.
J. E. B. Stuart was a general in the CSA.
If that sentence is placed at the start of the document, it creates infinite loop possibilities. Don't have a total fix for that yet, so just wanted to throw up the warning that CTRL+BREAK may be necessary for anyone exploring the above code.
Wow! You guys went above and beyond figuring this out. I have not tried the code yet but I sure didn't think it would be this complicated. I used to use WordPerfect and PerfectScript and it knew how to select a sentence even if there were abbreviations. Thanks so much for looking at this problem!
And we're done yet!! Check back as Jason and I are still polishing the cannonball.
Posting Permissions
Reply With Quote
