Sub FullPoint()
' Paul Beverley - Version 30.01.25
' Makes adjacent words into sentence end


newBit = ". "
myQuotes = Chr(34) & Chr(39) & ChrW(8220) & ChrW(8216)
oldBits = ";:.,!?" & ChrW(8211) & ChrW(8211)
Set rng = Selection.Range.Duplicate
rng.MoveEnd , 50
For i = 1 To rng.Characters.count
  If InStr(oldBits, rng.Characters(i)) > 0 Then Exit For
Next i
If i > 50 Then
  Beep
  MsgBox "No relevant punctuation found."
  Exit Sub
End If
rng.Characters(i).Select
Selection.Collapse wdCollapseStart
If i > 1 Then
  If rng.Characters(i - 1) = " " Then _
       rng.Characters(i - 1).Delete
End If
myStart = Selection.start
If Selection = ChrW(8217) Then myStart = myStart + 1
Do
  Selection.MoveRight 1
  DoEvents
  If Selection.start = ActiveDocument.Content.End - 1 _
       Then Beep: Exit Sub
Loop Until LCase(Selection) <> UCase(Selection) Or Asc(Selection) = 1
myEnd = Selection.start
If UCase(Selection) <> Selection Then
' It needs uppercasing
  Selection.start = Selection.start - 1
  preChar = Selection
  Selection.MoveStart 1
  Selection.MoveEnd 1
  newLetter = UCase(Selection)
  If InStr(myQuotes, preChar) > 0 Then
    Selection.Delete
    Selection.TypeText newLetter
    Selection.End = myEnd - 1
  Else
    newBit = newBit & newLetter
  End If
  Selection.start = myStart
Else
  newBit = Trim(newBit)
  Selection.MoveLeft 1
End If
Selection.start = myStart
If Right(Selection, 1) = " " And Len(Selection) > 1 Then
  Selection.End = Selection.End - 1
  newBit = Trim(newBit)
End If
If Selection.End <> myStart Then Selection.Delete
Selection.TypeText newBit
End Sub