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