Sub ParticipleChanger()
' Paul Beverley - Version 06.04.23
' Toggles between past and present participles

If Asc(Selection) = 32 Then Selection.MoveRight , 1
fstChar = Left(Selection, 1)
If UCase(fstChar) = LCase(fstChar) Then Selection.MoveLeft , 1
Selection.Expand wdWord
Do While InStr(ChrW(8217) & ChrW(39) & " ", Right(Selection.Text, 1)) > 0
  Selection.MoveEnd , -1
  DoEvents
Loop

' Beware being close to a comment
allCmts = ActiveDocument.Comments.count
cmt = allCmts
If allCmts > 0 Then
  Set rng = Selection.Range.Duplicate
  rng.Start = 0
  cmt1 = rng.Comments.count
  rng.End = Selection.Start
  cmt0 = rng.Comments.count
  If cmt0 = cmt1 Then
    cmt = cmt1 + 1
  Else
    cmt = cmt1
  End If
  If cmt <= allCmts Then
    ' Find start and end of comment scope
    cmStart = ActiveDocument.Comments(cmt).Scope.Start
    cmEnd = ActiveDocument.Comments(cmt).Scope.End
    myStart = Selection.Start
    myEnd = Selection.End
    
    ' Warn if you're too close
    doWarn = False
    If myStart < cmStart And myEnd > cmStart Then doWarn = True
    If myEnd - cmEnd < 3 And myEnd > cmEnd Then doWarn = True
    If (myEnd > cmEnd) And (myStart < cmEnd) Then doWarn = True
    If doWarn = True Then
      Beep
      myResponse = MsgBox("Beware: too close to a comment!", vbQuestion + vbcancelonly, _
           "ParticipleChanger")
      Exit Sub
    End If
  End If
End If
wd = Selection

rtChars = Right(wd, 3)

If rtChars = "ing" Then
' Remove 'ing' and try adding an 'ed'
  newWord = Left(wd, Len(wd) - 3) & "ed"
Else
' Remove 'ed' and try adding an 'ing'
  twoChars = Right(Selection.Text, 2)
  lft = Left(wd, Len(wd) - 2)
  Select Case twoChars
    Case "ed": newWord = lft & "ing"
    Case "lt": newWord = lft & "lling"
    Case "nt": newWord = lft & "ning"
    Case "an": newWord = lft & "inning"
    Case "un": newWord = lft & "inning"
    Case Else: Beep
  End Select
End If
Selection.Text = newWord
spellOK = Application.CheckSpelling(newWord)
If spellOK = False Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
End If
Selection.Collapse wdCollapseEnd
Selection.MoveLeft , 1
End Sub