Function ProperCase(StrTxt As String, Optional Caps As Long, Optional Excl As Long) As String
'Convert an input string to proper-case.
'Surnames like O', Mc and hyphenated names are converted to proper case also.
'If Caps = 0, then upper-case strings like ABC are preserved; otherwise they're converted.
'If Excl = 0, selected words are retained as lower-case, except when they follow specified punctuation marks.
Dim i As Long, j As Long, k As Long, l As Long, bChngFlg As Boolean
Dim StrTmpA As String, StrTmpB As String, StrExcl As String, StrPunct As String, StrChr As String
StrExcl = " a , an , and , as , at , but , by , for , from , if , in , is , of , on , or , the , this , to , with "
StrPunct = "!,:,.,?,"""
If Excl <> 0 Then
  StrExcl = ""
  StrPunct = ""
End If
If Len(Trim(StrTxt)) = 0 Then
  ProperCase = StrTxt
  Exit Function
End If
If Caps <> 0 Then StrTxt = LCase(StrTxt)
StrTxt = " " & StrTxt & " "
For i = 1 To UBound(Split(StrTxt, " "))
  StrTmpA = " " & Split(StrTxt, " ")(i) & " "
  StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
  StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next i
StrTxt = Trim(StrTxt)
'Code for handling O' names
For i = 1 To UBound(Split(StrTxt, "'"))
  ' If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Then
  If InStr(Right(Split(StrTxt, "'")(i - 1), 2), " ") = 1 Or _
    Right(Split(StrTxt, "'")(i - 1), 2) = Right(Split(StrTxt, "'")(i - 1), 1) Then
    StrTmpA = Split(StrTxt, "'")(i)
    StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
    StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
  End If
Next
'Code for handling hyphenated names
For i = 1 To UBound(Split(StrTxt, "-"))
  StrTmpA = Split(StrTxt, "-")(i)
  StrTmpB = UCase(Left(StrTmpA, 1)) & Right(StrTmpA, Len(StrTmpA) - 1)
  StrTxt = Replace(StrTxt, StrTmpA, StrTmpB)
Next
'Code for handling names starting with Mc
If Left(StrTxt, 2) = "Mc" Then
  Mid(StrTxt, 3, 1) = UCase(Mid(StrTxt, 3, 1))
End If
i = InStr(StrTxt, " Mc")
If i > 0 Then
  Mid(StrTxt, i + 3, 1) = UCase(Mid(StrTxt, i + 3, 1))
End If
'Code for handling names starting with Mac
If Left(StrTxt, 3) = "Mac" Then
  If Len(Split(Trim(StrTxt), " ")(0)) > 5 Then
    Mid(StrTxt, 4, 1) = UCase(Mid(StrTxt, 4, 1))
  End If
End If
i = InStr(StrTxt, " Mac")
If i > 0 Then
  If Len(StrTxt) > i + 5 Then
    Mid(StrTxt, i + 4, 1) = UCase(Mid(StrTxt, i + 4, 1))
  End If
End If
'Code to restore excluded words to lower case
For i = 0 To UBound(Split(StrExcl, ","))
  StrTmpA = Split(StrExcl, ",")(i)
  StrTmpB = UCase(Left(StrTmpA, 2)) & Right(StrTmpA, Len(StrTmpA) - 2)
  If InStr(StrTxt, StrTmpB) > 0 Then
    StrTxt = Replace(StrTxt, StrTmpB, StrTmpA)
    'Make sure an excluded words following punctution marks are given proper case anyway
    For j = 0 To UBound(Split(StrPunct, ","))
      StrChr = Split(StrPunct, ",")(j)
      StrTxt = Replace(StrTxt, StrChr & StrTmpA, StrChr & StrTmpB)
    Next
  End If
Next
ProperCase = StrTxt
End Function

Sub Reformat()
Dim i As Long, StrChr As String, StrTmp As String
With Selection
  For i = 1 To .Words.Count
    StrChr = Left(.Words(i), 1)
    If StrChr = LCase(StrChr) Then
      StrTmp = StrTmp & LCase(.Words(i))
    Else
      StrTmp = StrTmp & StrChr & LCase(Mid(.Words(i), 2, Len(.Words(i)) - 1))
    End If
  Next
  .Text = StrTmp
End With
End Sub

Function AllLowerCase(stringToCheck As String) As Boolean

    AllLowerCase = StrComp(stringToCheck, LCase(stringToCheck), _
       vbBinaryCompare) = 0
End Function

Sub Reformat()
Dim i As Long, StrTmp As String
With Selection
  For i = 1 To .Words.Count
    If .Words(i) = LCase(.Words(i)) Then
      StrTmp = StrTmp & .Words(i)
    Else
      StrTmp = StrTmp & UCase(Left(.Words(i), 1)) & LCase(Mid(.Words(i), 2, Len(.Words(i)) - 1))
    End If
  Next
  .Text = StrTmp
End With
End Sub