Word VBA Find Passive Voice - vba

Question

I have written a procedure to find passive constructions, e.g. 'was solved', 'been written', i.e. passives ending in 'ed' or 'en', but not things like 'was fruitful'. A comment is inserted for each find.
I'm almost there - but cannot fix a couple of anomalies:
It works for 'was solved.' , 'was solved .' and 'was solved ', (NB spaces in two of these) but not in 'was solved today', i.e. where there are more words after the final verb. This last error is the one I wish to fix.
It also finds the passives in 'is being completed', i.e. two auxiliary verbs together, whether spaces follow the final verb or not. This is an added bonus, apart from the fact that the find is indicated twice.
I suspect this is to do with my Is_Alpha function, which strips punctuation from the end of the main verb.
Thanks folks, any help appreciated.
Sub Passives3()
Dim P_Flag As Boolean
Dim P_Cmt As Comment
Dim P_Rng As Range
Dim P_Rng2 As String
Dim P_New As String
Dim P_Fnd As Boolean
Dim Cmt As Comment
Dim P_Range As Range
Dim P_Ctr As Long
Dim Com_plete As Integer
Dim P_Word(7) As String
P_Word(0) = "am "
P_Word(1) = "are "
P_Word(2) = "be "
P_Word(3) = "been "
P_Word(4) = "being "
P_Word(5) = "is "
P_Word(6) = "was "
P_Word(7) = "were "
For P_Ctr = LBound(P_Word) To UBound(P_Word)
Set P_Rng = ActiveDocument.Range
With P_Rng.Find
.ClearFormatting
.text = P_Word(P_Ctr)
Debug.Print .text
.MatchCase = False
.MatchWholeWord = True
While .Execute
If P_Rng.Find.Found Then
Dim P_test As Range
Set P_test = P_Rng.Duplicate
With P_test
.MoveEnd wdWord, 2
.Select
P_New = P_test
Call Is_Alpha(P_New, P_Flag)
If P_Flag = False Then
P_New = Left(P_New, Len(P_New) - 1)
End If
End With
If (Right(Trim(P_New), 2)) = "ed" _
Or (Right(Trim(P_New), 2)) = "en" Then
Set P_Cmt = P_Rng.Comments.Add(Range:=P_Rng, text:="Passive? " & P_New)
P_Cmt.Author = "Passives"
P_Cmt.Initial = "PSV "
P_Cmt.Range.Font.ColorIndex = wdGreen
End If
End If
Wend
End With
Next
End Sub
Function Is_Alpha(P_New As String, P_Flag As Boolean) As Boolean
If Asc(Right(P_New, 1)) > 64 And Asc(Right(P_New, 1)) < 90 Or _
Asc(Right(P_New, 1)) > 96 And Asc(Right(P_New, 1)) < 123 Then
P_Flag = True
Else
P_Flag = False
End If
End Function

Answer 1

How about:
Sub Passives()
Dim i As Long, j As Long, Cmt As Comment, P_Words, X_Words
P_Words = Array("am ", "are ", "be ", "been ", "being ", "is ", "was ", "were ")
X_Words = Array("am ", "are ", "being ", "is ", "was ", "were ", "has ", "have ")
For i = LBound(P_Words) To UBound(P_Words)
With ActiveDocument.Range
With .Find
.ClearFormatting
.Text = "<" & P_Words(i) & "[! ]#e[dn]>"
.MatchWildcards = True
End With
Do While .Find.Execute
For j = LBound(X_Words) To UBound(X_Words)
If .Words.First.Previous.Words.First.Text = X_Words(j) Then
.Start = .Words.First.Previous.Words.First.Start
End If
Next
Set Cmt = .Comments.Add(Range:=.Duplicate, Text:="Passive?")
With Cmt
.Author = "Passives"
.Initial = "PSV "
.Range.Font.ColorIndex = wdGreen
End With
.Collapse wdCollapseEnd
Loop
End With
Next
End Sub