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


maxWords = 5
listNameIncludes = "switch"
commentNearCheck = True

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

linksOFF = True

addMarkerInList = True

notTheseChars = ",!?.)>] "

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

' On a Mac, you will need something like this:
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
On Error GoTo ReportIt

Set theDoc = ActiveDocument

' Just in case they are using "smart" cut/paste option
mySmartOpt = Options.SmartCutPaste
Options.SmartCutPaste = False
nowSearch = Selection.Find.Text

' Read the context, noting if the word is selected
wasSelected = (Selection.End > Selection.start)
If wasSelected = True Then maxWords = 1
myTest = Selection.Text
If Asc(myTest) = 13 Then Selection.MoveLeft , 1
If InStr(notTheseChars, myTest) > 0 Then Selection.MoveLeft , 1
Selection.Expand wdWord
Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
  Selection.MoveEnd , -1
  DoEvents
Loop

okChars = ".,;:" & Chr(11) & vbCr & 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) = Trim(Left(rng, endStr(i) - rng.start))
  DoEvents
Next i
If numTCs > 0 Then WordBasic.EditUndo
Selection.Collapse wdCollapseStart

iMax = maxWords

gottaList = False
For Each myDoc In Application.Documents
  thisName = myDoc.Name
  If InStr(LCase(thisName), LCase(listNameIncludes)) > 0 Then
    Set theList = Documents(thisName)
    gottaList = True
    Exit For
  End If
Next myDoc

' Find the zzSwitchList file
If gottaList = False Then
  Documents.Open fileName:=myList
  Set theList = ActiveDocument
  theDoc.Activate
End If

Set rng = theList.Content
' Check if list has LFs
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Wrap = wdFindContinue
  .Text = ChrW(11)
  .Replacement.Text = ""
  .Execute
  DoEvents
  If .Found = True Then
    Beep
    rng.start = rng.start - 1
    rng.Collapse wdCollapseStart
    rng.Expand wdWord
    rng.HighlightColorIndex = wdYellow
    rng.Collapse wdCollapseEnd
    rng.Select
    MsgBox "The switch list must use paragraphs, not line breaks!"
    ActiveWindow.ActivePane.View.ShowAll = True
    rng.Find.Text = nowSearch
    Exit Sub
  End If
End With

' Just in case the switch list has any URLs
If linksOFF = True Then
  rng.Fields.Unlink
End If
lastTwo = Right(rng, 2)
If lastTwo <> CR2 Then rng.InsertAfter Text:=CR2
firstTwo = Left(rng, 2)
If firstTwo <> CR2 Then rng.InsertBefore Text:=CR2

rng.start = 0
rng.End = theList.Content.End
' Try to locate the selected text in the switch list
allWords = rng.Text
lfPos = InStr(allWords, ChrW(11))
If lfPos > 0 Then
  rng.start = lfPos - 2
  rng.End = lfPos + 1
  rng.Select
  Beep
  Application.Run "ShowFormatting"
  MsgBox "The switch list must use paragraphs, not line breaks!"
  Options.SmartCutPaste = mySmartOpt
  Selection.Find.Text = nowSearch
  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 = 20
    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 rng.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 rng.Find.Found = True Or Len(myWd) = 1
  rng.Collapse wdCollapseStart
  rng.Select
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  Options.SmartCutPaste = mySmartOpt
  Selection.Find.Text = nowSearch
  Debug.Print "|" & myStr(1) & "|"
  myPrompt = "Can't find """ & myStr(1) & """"
  myResponse = MsgBox(myPrompt, vbOKOnly, "MultiSwitch")
  theDoc.Activate
  Exit Sub
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
    Options.SmartCutPaste = mySmartOpt
    Selection.Find.Text = nowSearch
    Exit Sub
  End If
Else
  myChoice = 1
End If
rng.start = myPos + 2
rng.Collapse wdCollapseStart
rng.Expand wdParagraph

For i = 1 To myChoice
  rng.Collapse wdCollapseEnd
  rng.Expand wdParagraph
Next i
' Copy chosen line (check first for format change symbol)
useFormat = False
rng.MoveEnd , -1
myNewItem = rng
Dim gotFormat As Boolean
gotFormat = rng.Font.Bold Or rng.Font.Italic Or rng.Font.SmallCaps _
     Or rng.Font.Underline Or rng.Font.Superscript Or rng.Font.Subscript _
     Or rng.InlineShapes.count > 0
If rng.Text = "" Then Beep: Exit Sub
If AscW(rng) = 172 Or gotFormat Then
  useFormat = True
  If AscW(rng) = 172 Then rng.MoveStart , 1
  rng.Copy
End If
noTrack = (rng.Font.StrikeThrough)
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
        Selection.Find.Text = nowSearch
        Exit Sub
      End If
    End If
  End If
End If

With ActiveWindow.View.RevisionsFilter
  myMarkup = .Markup
  myView = .View
End With
myTrack = ActiveDocument.TrackRevisions
If removeHighlight = True Then
  ActiveDocument.TrackRevisions = False
  Selection.MoveEnd , 1
  Selection.Range.HighlightColorIndex = wdNoHighlight
  Selection.MoveEnd , -1
  ActiveDocument.TrackRevisions = myTrack
End If

myTrack = ActiveDocument.TrackRevisions
If noTrack Then ActiveDocument.TrackRevisions = False
If useFormat = True Then
  Selection.Delete
  Selection.Paste
Else
  Selection.Text = myNewItem
End If
ActiveDocument.TrackRevisions = myTrack

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

ActiveDocument.TrackRevisions = myTrack
With ActiveWindow.View.RevisionsFilter
  .Markup = myMarkup
  .View = myView
End With
Options.SmartCutPaste = mySmartOpt
Selection.Find.Text = "^p^p" & myStr(1)
Exit Sub

ReportIt:
myErr = Err.Number
If myErr = 4160 Then
  DoEvents
  gottaList = False
  Resume Next
Else
  If myErr = 438 Then Beep: Exit Sub
  If myErr = 5174 Then
    Beep
    myPrompt = "Please open your switch list file: " & myListName _
           & CR2 & CR & "I did try looking for file: " & CR2 & myList
    myResponse = MsgBox(myPrompt, vbQuestion + vbOKOnly, "MultiSwitch")
    Exit Sub
  End If
  DoEvents
  Resume
End If
End Sub