Sub OUPFetchPremium()
' Paul Beverley - Version 10.06.24
' Launches selected text to OUP Premium website.

mySite = "https://premium.oxforddictionaries.com/definition/english/"

myWait = 0.75
' Depending on your browser + internet connection
' you might need a longer wait, or could get away with less.

allowRerun = True
' allowRerun = False

testMode = False
' testMode = True

If Selection.Start = Selection.End Then
  Selection.Expand wdWord
  If LCase(Selection) = UCase(Selection) Then
    Selection.Collapse wdCollapseStart
    Selection.MoveStart wdWord, -1
  End If
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
Else
  endNow = Selection.End
  Selection.MoveLeft wdWord, 1
  startNow = Selection.Start
  Selection.End = endNow
  Selection.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  Selection.Start = startNow
End If

Selection.Copy
ActiveDocument.FollowHyperlink Address:=mySite
If testMode = True Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  Exit Sub
End If
myTime = Timer
Do
Loop Until Timer > myTime + myWait
SendKeys "^v"
SendKeys "{ENTER}"
myTime = Timer
If allowRerun = True Then
  myResponse = MsgBox("Rerun the search?! (Or press<Esc>)", _
       vbQuestion + vbYesNoCancel, "OUPFetchPremium")
  If myResponse <> vbYes Then
    SendKeys "{NUMLOCK}"
    Exit Sub
  End If
Else
  SendKeys "{NUMLOCK}"
  Exit Sub
End If

ActiveDocument.FollowHyperlink Address:=mySite
myTime = Timer
Do
Loop Until Timer > myTime + myWait
SendKeys "^v"
SendKeys "{ENTER}"
SendKeys "{NUMLOCK}"
End Sub