Sub MultiSwitch()
' Paul Beverley - Version 03.10.22
' Scripted word/phrase switching

maxWords = 5
myListName = "zzSwitchList"

commentNearCheck = True

' Set min number of chars for an abbreviation
minChars = 3
includeApostrophe = True

linksOFF = True

' addOriginal = True
addOriginal = False

Set thisDoc = ActiveDocument

' If you want to load the SwitchList file automatically...

' On a Mac, you will need
myList = "/Users/Paul/My Documents/Macro stuff/zzSwitchList.docx"

' On Windows, you will need something like this:
myList = "C:\Documents and Settings\Paul\My Documents\zzSwitchList.docx"


CR = vbCr
CR2 = CR & CR
Dim myStr(20) As String
Dim endStr(20) As Long

' Just in case they are using "smart" cut/opaste option
mySmartOpt = Options.SmartCutPaste
Options.SmartCutPaste = False

' Read the context, noting if the word is selected
wasSelected = (Selection.End > Selection.Start)
If wasSelected = True Then
  maxWords = 1
Else
  myTest = Selection.Text
  If LCase(myTest) = UCase(myTest) Then Selection.MoveLeft , 1
  Selection.Expand wdWord
End If
inAComment = Selection.Information(wdInCommentPane)
'If inAComment = True Then
' ' cmtText = Selection.Comments(1).Range.Words.count
'  numWds = Selection.Comments(1).Range.Words.count
'  If numWds = 1 Then Selection.InsertAfter Text:=" "
'End If

' If no word selected
Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
  Selection.MoveEnd , -1
  DoEvents
Loop
okChars = ".,;:" & Chr(13) & ChrW(8211) & ChrW(8212) & ChrW(8221)
If InStr(okChars, Left(Selection, 1)) > 0 Then
  Selection.Collapse wdCollapseStart
  Selection.MoveLeft , 1
  Selection.Expand wdWord
End If

isAbbrev = Not (Len(Selection) > minChars)
startNow = Selection.Start
Set startRng = Selection.Range.Duplicate
iMax = maxWords

Set rng = Selection.Range.Duplicate
rng.Collapse wdCollapseStart
rng.MoveEnd Unit:=wdWord, count:=maxWords
numTCs = rng.Revisions.count


If numTCs > 0 Then
  rng.Revisions.AcceptAll
  rng.MoveEnd Unit:=wdWord, count:=maxWords
End If

wdsLeft = rng.Words.count
If maxWords > wdsLeft Then maxWords = wdsLeft
If Asc(rng.Words(wdsLeft)) = 13 Then maxWords = maxWords - 1
For i = 1 To maxWords
  endStr(i) = rng.Words(i).End
  If rng.Words(i) = vbCr Then
    maxWords = i - 1
    Exit For
  End If
  If Right(rng.Words(i), 1) = " " Then endStr(i) = endStr(i) - 1
  myStr(i) = Left(rng, endStr(i) - rng.Start)
  DoEvents
Next i
If numTCs > 0 Then WordBasic.EditUndo
Selection.Collapse wdCollapseStart

iMax = maxWords

' Find the zzSwitchList file
gottaList = False
For i = 1 To Documents.count
  Set dcu = Documents(i)
  If InStr(dcu.Name, myListName) > 0 Then
    Set listDoc = dcu
    gottaList = True
    Exit For
  End If
Next i
If gottaList = False Then
  Documents.Open FileName:=myList
'  Beep
'  myResponse = MsgBox("Please open the " & myListName & _
       " file.", vbOKOnly, "MultiSwitch")
'  Options.SmartCutPaste = mySmartOpt
'  Exit Sub
Else
  listDoc.Activate
End If
' Check if list has LFs
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ChrW(11)
  .Replacement.Text = ""
  .Execute
  DoEvents
  If .Found Then
    Beep
    MsgBox "The switch list must use paragraphs, not line breaks!"
    ActiveWindow.ActivePane.View.ShowAll = True
    Exit Sub
  End If
End With

' Just in case the switch list has any URLs
If linksOFF = True Then
  Set rngList = ActiveDocument.Content
  rngList.Fields.Unlink
End If

Set rng = ActiveDocument.Content
rng.End = 2
If rng.Text <> CR2 Then rng.InsertBefore Text:=CR2

' Try to locate the selected text in the switch list
Set rng = ActiveDocument.Content
allWords = rng.Text
lfPos = InStr(allWords, ChrW(11))
If lfPos > 0 Then
  Selection.Start = lfPos - 2
  Selection.End = lfPos + 1
  Beep
  Application.Run "ShowFormatting"
  MsgBox "The switch list must use paragraphs, not line breaks!"
  Options.SmartCutPaste = mySmartOpt
  Exit Sub
End If

For i = iMax To 1 Step -1
  myPos = InStr(allWords, CR2 & Replace(myStr(i), CR, "") & CR)
  If myPos > 0 Then
    allWords = Mid(allWords, myPos + 1)
    gottaMatch = True
    numWords = i
  'Display the options
    numAlts = 1
    endPos = InStr(allWords, CR2)
    allWords = Left(allWords, endPos + 2)
    altText = Split(allWords, Chr(13))
    j = 0
    Do
      j = j + 1
    Loop Until Len(altText(j)) = 0 Or j = 10
    numAlts = j - 2
    ' We now have j = number of options
    ' altText contains all numAlts texts
    Exit For
  Else
    gottaMatch = False
  End If
Next i

' If it's not found at all, give up
If gottaMatch = False Then
  myWd = myStr(1)
  Do
    With Selection.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "^p^p" & myWd
      .Wrap = wdFindContinue
      .Replacement.Text = ""
      .Forward = True
      .MatchCase = True
      .MatchWildcards = False
      .Execute
      .MatchCase = False
    End With
    If Len(myWd) > 1 Then myWd = Left(myWd, Len(myWd) - 1)
  Loop Until Selection.Find.Found = True Or Len(myWd) = 1
  Selection.Collapse wdCollapseStart
  thisDoc.Activate
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  Options.SmartCutPaste = mySmartOpt
  Exit Sub
  Else
  Selection.Start = myPos + 20
  Selection.MoveLeft , 19
End If

'Offer j optional texts to the user
If numAlts > 1 And wasSelected = False Then
  For i = 1 To numAlts
    myPrompt = myPrompt & i & ":  " & altText(i + 1) & CR
  Next
  Beep
  myResponse = InputBox(myPrompt, "MultiSwitch")
  myChoice = Val(myResponse)
  If myChoice > numAlts Or myChoice = 0 Then
    thisDoc.Activate
    Options.SmartCutPaste = mySmartOpt
    Exit Sub
  End If
Else
  myChoice = 1
End If
Selection.Start = myPos + 2
Selection.Expand wdParagraph
For i = 1 To myChoice
  Selection.Collapse wdCollapseEnd
  Selection.Expand wdParagraph
Next i
' Copy chosen line (check first for format change symbol)
useFormat = False
Selection.MoveEnd , -1
myNewItem = Selection
Set r = Selection.Range
Dim gotFormat As Boolean
gotFormat = r.Font.Bold Or r.Font.Italic Or r.Font.SmallCaps _
     Or r.Font.Underline Or r.Font.Superscript Or r.Font.Subscript _
     Or r.InlineShapes.count > 0
If AscW(Selection) = 172 Or gotFormat Then
  useFormat = True
  If AscW(Selection) = 172 Then Selection.MoveStart , 1
  Selection.Copy
End If
noTrack = (Selection.Font.StrikeThrough)
thisDoc.Activate
startRng.Select
Selection.End = endStr(numWords)

' Check if too near to a comment
If Selection.Information(wdInCommentPane) = 0 And _
     Selection.Information(wdInFootnote) = 0 And _
     Selection.Information(wdInEndnote) = 0 Then

  numCmts = ActiveDocument.Comments.count
  If numCmts > 0 And commentNearCheck = True Then
  ' Find scope of (range covered by) the next comment
    Set rng = Selection.Range.Duplicate
    rng.Collapse wdCollapseStart
    rng.Start = 0
    cmtNumber = rng.Comments.count + 1
    If cmtNumber <= numCmts Then
      Set nextCmtRange = ActiveDocument.Comments(cmtNumber).Scope
      
    ' Does the scope of that comment overlap the current word?
      Set rng = Selection.Range.Duplicate
      rng.Expand wdWord
      If rng.End > nextCmtRange.Start Then
        Beep
        rng.Select
        myResponse = MsgBox("Selection contains a comment. Word might crash!" _
             & CR2 & "Please use a manual change.", _
             vbOKOnly, "MultiSwitch")
        Options.SmartCutPaste = mySmartOpt
        Exit Sub
      End If
    End If
  End If
End If

myTrack = ActiveDocument.TrackRevisions
myState = ActiveWindow.View.ShowInsertionsAndDeletions
If noTrack Then ActiveDocument.TrackRevisions = False
Selection.Delete
If useFormat = True Then
  Selection.Paste
Else
  Selection.TypeText Text:=myNewItem
End If
Selection.Start = startNow
textEnd = Selection.End
If InStr(Selection, "^p") > 0 Then
  numCRs = 0
  oldFind = Selection.Find.Text
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^^p"
    .Wrap = wdFindContinue
    .Replacement.Text = ""
    .Forward = True
    .MatchCase = False
    .MatchWildcards = False
    .Execute
  End With
  Do While Selection.Find.Found = True And Selection.Start < textEnd
    Selection.TypeText Text:=vbCr
    Selection.Find.Execute
    numCRs = numCRs + 1
  Loop
  Selection.Start = startNow
  Selection.End = textEnd - numCRs
  Selection.Find.Text = oldFind
End If
If InStr(Selection, "^t") > 0 Then
  numTabs = 0
  oldFind = Selection.Find.Text
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^^t"
    .Wrap = wdFindContinue
    .Replacement.Text = ""
    .Forward = True
    .MatchCase = False
    .MatchWildcards = False
    .Execute
  End With
  Do While Selection.Find.Found = True And Selection.Start < textEnd
    Selection.TypeText Text:=vbTab
    Selection.Find.Execute
    numTabs = numTabs + 1
  Loop
  Selection.Start = startNow
  Selection.End = textEnd - numCRs - numTabs
  Selection.Find.Text = oldFind
End If
If Asc(Selection) = Asc("!") Then
  myLen = Len(Selection)
  Selection.End = Selection.Start + 1
  Selection.Start = Selection.Start - 1
  Selection.Delete
  Selection.MoveEnd , myLen - 1
End If
tildePos = InStr(Selection, "~")
Selection.Font.StrikeThrough = False
If tildePos = 0 Then
  If isAbbrev = True Then
    Selection.Collapse wdCollapseEnd
  Else
    Selection.Collapse wdCollapseStart
  End If
Else
  Do While InStr(Selection, "~") > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  Selection.Collapse wdCollapseEnd
  Selection.MoveEnd 1
  Selection.Delete
End If
If addOriginal = True Then
  Selection.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  Selection.Collapse wdCollapseEnd
  Selection.TypeText Text:=" (" & myStr(1) & ")"
End If

If noTrack Then
  ActiveDocument.TrackRevisions = myTrack
  ActiveWindow.View.ShowInsertionsAndDeletions = myState
End If
Options.SmartCutPaste = mySmartOpt
End Sub