Sub CaseNextChar()
' Paul Beverley - Version 13.04.24
' Changes case of the next character/selection

trackit = True
trackIfSelected = False

myShow = ActiveWindow.View.ShowRevisionsAndComments
myView = ActiveWindow.View.RevisionsView
myTrack = ActiveDocument.TrackRevisions

' Don't track case change if TC is OFF
If myTrack = False Then trackit = False

' If an area of text is NOT selected ...
If Selection.End = Selection.Start Then
  If trackit = False Then _
       ActiveDocument.TrackRevisions = False
  Set rng = Selection.Range.Duplicate
  rng.MoveEnd , 1
  Do While LCase(rng) = UCase(rng)
    rng.MoveEnd , 1
    rng.MoveStart , 1
    DoEvents
  Loop
  rng.Select
  If UCase(rng) = rng Then
    myNewChar = LCase(rng)
  Else
    myNewChar = UCase(rng)
  End If
  rng.Delete
  rng.Select
  Selection.TypeText Text:=myNewChar
Else
' If an area of text is selected ...
  If trackIfSelected = False Then trackit = False
  If Selection.Information(wdWithInTable) = True Then
    If Selection.Range.Case = wdLowerCase Then
      Selection.Range.Case = wdUpperCase
    Else
      Selection.Range.Case = wdLowerCase
    End If
  Else
    myText = Selection
    voteUpper = 0
    voteLower = 0
    For myCount = 1 To Len(myText)
      myChar = Asc(Mid(myText, myCount, 1))
      If myChar > 96 And myChar < 123 Then voteLower = voteLower + 1
      If myChar > 64 And myChar < 91 Then voteUpper = voteUpper + 1
    Next myCount
    myUpper = (voteUpper > voteLower)
    If voteLower = 0 Then myUpper = False
    If trackit = False Then
      ActiveDocument.TrackRevisions = False
      If myUpper = True Then
        Selection.Range.Case = wdUpperCase
      Else
        Set rng = Selection
        For Each myWd In rng.Words
          If Len(myWd) > 1 Then
            myCh1 = Left(myWd, 1)
            myCh2 = Mid(myWd, 2, 1)
            If LCase(myCh1) <> myCh1 And UCase(myCh2) <> myCh2 And _
                 myWd.Start >= rng.Start Then _
                 myWd.Case = wdLowerCase
          End If
        Next myWd
      End If
      If Selection = myText Then Selection.Range.Case = wdUpperCase
      If Selection = myText Then Selection.Range.Case = wdLowerCase
    Else
      startWas = Selection.Start
      If myUpper = True Then
        myTextNew = UCase(myText)
      Else
        myTextNew = LCase(myText)
      End If
      If myTextNew = myText Then myTextNew = UCase(myText)
      If myTextNew = myText Then myTextNew = LCase(myText)
      wasBold = Selection.Font.Bold
      wasItalic = Selection.Font.Italic
      Selection.Delete
      Selection.TypeText Text:=myTextNew
      Selection.Start = startWas
      If wasBold Then Selection.Font.Bold = True
      If wasItalic Then Selection.Font.Italic = True
    End If
  End If
End If
ActiveDocument.TrackRevisions = myTrack
ActiveWindow.View.ShowRevisionsAndComments = myShow
End Sub