Sub SmartFinder()
' Paul Beverley - Version 03.02.25
' Finds this text/note/page/etc, etc immediately.


A = ""
A = A & "w = web address|"
A = A & "a = acronym|"
A = A & "d/D = date|"
A = A & "h = heading|"
A = A & "|"
A = A & "p = postcode|"
A = A & "Z = zipcode|"
A = A & "y = year [2014]|"
A = A & "< = tag <A>, <Cap>|"
A = A & " = |"
A = A & " = |"
A = A & " = |"
A = A & " = |"


endPos = InStr(A, "= |")
If endPos > 0 Then A = Left(A, endPos - 3)
myPrompt = Replace(A, "|", vbCr)

existingFind = Selection.Find.Text
startMyText = Selection.start
endMyText = Selection.End
selText = Selection
' If nothing selected, pick up the current word
noTextSelected = (Selection.End = Selection.start)
If noTextSelected Then
  cursorPosn = Selection.start
  Selection.Expand wdWord
  Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
    Selection.MoveEnd , -1
    DoEvents
  Loop
  selText = Selection
' Ends of the current word
  startMyText = Selection.start
  endMyText = Selection.End
' Put the cursor back where it was
  Selection.End = cursorPosn
  Selection.start = cursorPosn
End If

selText = Trim(selText)

' For safety, first clear all 'funny' finds down
With Selection.Find
  .Wrap = wdFindStop
  .Forward = True
  .Text = ""
  .MatchAllWordForms = False
  .MatchWildcards = False
  .MatchWholeWord = False
  .MatchSoundsLike = False
End With

inputCommand:
myText = InputBox(myPrompt, "Smart finder", selText)
If Len(myText) = 0 Then Exit Sub
myText = Replace(myText, Chr(13), "")

' Default settings for all searches
mvStart = 0
mvEnd = 0
myReplace = ""
myStyle = ""
isBold = False
isItalic = False
isSuper = False
isSub = False
isSmalls = False
thisSize = 0
nmlSize = 0
thisFont = ""
nmlFont = ""
thisColour = 0
nmlColour = 0
myCase = False
sndsLike = False
wholeWds = False
allForms = False

If Len(myText) > 1 Then GoTo moreText
' Single-letter commands
WC = True
myReplace = ""
Select Case myText
  Case "a": myFind = "[A-Z]{2,}" ' acronyms (see also x and X)
  Case "B": myFind = "[ABC][DCE]" ' BC/AD/CE/BCE
  Case "b": myFind = "[abc][dce]" ' BC/AD/CE/BCE in small caps
    wasSmalls = 0: isSmalls = True
  Case "d": myFind = "[123][0-9] [A-O][a-z]@ [0-9]{2,4}" ' dates
  Case "D": myFind = "[0-9]{1,2}.[0-9]{1,2}.[0-9]{2,4}" ' dates
  Case "e" ' Do nowt and then later jump back to input function
  ' f is for font attributes - see below
  ' h is for headings - see below
  Case "E": myFind = "[A-Z][ \-,][0-9]{4}"
  
  Case "i": myFind = "[A-Z]. [A-Z][a-z]" ' People's initials dotted
  Case "I": myFind = "[A-Z]{1,} [A-Z][a-z]" ' People's initials, no dots
  Case "m": myFind = "[ .^13][a-zA-Z]@\@[a-zA-Z]@.[a-zA-Z]{1,}" ' emails
  Case "n": myFind = "[0-9]{1,}" ' numbers
  ' M is macro select, below
  Case "s": myFind = "^13[0-9]{1,}.[0-9]{1,}": mvStart = 1 ' section numbers
  Case "p": myFind = "[A-Z]{1,2}[0-9]{1,2} [0-9][A-Z]{2}" ' postcodes
  Case "u": myFind = "[0-9 ^0160" & ChrW(8201) & "][kcmM][NJAVmg]>" ' units
  Case "w": myFind = "[wt]{2}[wp][.:][a-z/]{2,}" ' web addresses
  ' x is expand acronym below
  ' X is expand acronym, case insensitively below
  Case "y": myFind = "[12][0-9]{3}[!0-9]": mvEnd = -1 ' years
  Case "z": myFind = "<[0-9]{5}>"
  Case "Z": myFind = "[A-Z][0-9][A-Z] [0-9][A-Z][0-9]>"
  Case "<": myFind = "\<[ABDCapHN]{1,3}\>"
  Case "(": myFind = "\([0-9.]@\)" ' Number in brackets: (3.16), (12.2)
  Case ")": myFind = "^13([0-9]{1,2}). ": myReplace = "^p\1^t"
  Case "[": myFind = "[[[[[": WC = False
  Case "#": myFind = "^p^#": WC = False
  
  Case "-":
    hyphenPos = InStr(selText, "-")
    spacePos = InStr(selText, " ")
    enPos = InStr(selText, ChrW(8211))
    markerPos = hyphenPos + spacePos + enPos
    If markerPos = 0 Then
      If Len(Selection) = 1 Then
        Selection.Expand wdWord
        Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
          Selection.MoveEnd , -1
          DoEvents
        Loop
        selText = Selection
      End If
      Beep
      wd1 = InputBox("First word?", "FindAnything", selText)
      If wd1 = selText Then
        Selection.MoveRight wdWord, 1
        Selection.Expand wdWord
        Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
          Selection.MoveEnd , -1
          DoEvents
        Loop
        wd2 = Selection
        If wd2 = "-" Or wd2 = ChrW(8211) Then
          Selection.MoveRight wdWord, 1
          Selection.Expand wdWord
          Do While InStr(ChrW(8217) & "' ", Right(Selection.Text, 1)) > 0
            Selection.MoveEnd , -1
            DoEvents
          Loop
          wd2 = Selection
        End If
      Else
        wd2 = Mid(selText, Len(wd1) + 1)
      End If
    Else
      wd1 = Left(selText, markerPos - 1)
      wd2 = Mid(selText, markerPos + 1)
    End If
    If Len(wd1) = 0 Then
      Beep
      Exit Sub
    End If
    myFind = Left(wd1, Len(wd1) - 1) & "[" & Right(wd1, 1) _
         & Left(wd2, 1) & "\- ^=]{2,3}" & Mid(wd2, 2)
    WC = True
  
  Case "A": myFind = Trim(Replace(selText, " ", ""))
    allForms = True: WC = False
  Case "S": myFind = Trim(selText): sndsLike = True: WC = False
  Case "W": myFind = Trim(selText): wholeWds = True: WC = False
      
  Case "x" ' Xpand, i.e. look for acronym expansion
    myFind = "<"
    abbrLength = Len(selText)
    For i = 1 To abbrLength
      myFind = myFind & Mid(selText, i, 1) & "[a-z]{1,}^32"
    Next i
    myFind = Left(myFind, Len(myFind) - 3)

  Case "X" ' Xpand, i.e. look for acronym expansion, either case
    myFind = "<"
    abbrLength = Len(selText)
    For i = 1 To abbrLength
      If i = 4 Then Exit For
      myChar = Mid(selText, i, 1)
      myChar = "[" & LCase(myChar) & UCase(myChar) & "]"
      myFind = myFind & myChar & "[a-z]{1,}^32"
    Next i
    myFind = Left(myFind, Len(myFind) - 3)

  Case "h": WC = False: myFind = "" ' A heading
    myStyle = Selection.Range.Style
    If myStyle = "Normal" Then
      myStyle = ""
      Selection.End = Selection.start + 1
      Selection.Font.Reset
      nmlSize = Selection.Font.Size
      nmlFont = Selection.Font.Name
      nmlColour = Selection.Font.Color
      wasBold = Selection.Font.Bold
      wasItalic = Selection.Font.Italic
    ' undo the change, i.e. restore the text's original attributes
      WordBasic.EditUndo
    ' Check the text's emphasis now
      isBold = Selection.Font.Bold
      isItalic = Selection.Font.Italic
      thisSize = Selection.Font.Size
      thisFont = Selection.Font.Name
      thisColour = Selection.Font.Color
    End If
    Selection.Expand wdParagraph
    If myStyle = "" And wasBold = isBold And wasItalic = isItalic _
         And thisSize = nmlSize And thisFont = nmlFont _
         And thisColour = nmlColour Then
      myFind = "^p" & Left(Selection, 1)
    End If
    Selection.start = Selection.End
  
  Case "f": WC = False: myFind = "" ' Font attributes
    If Selection.End = Selection.start Then Selection.MoveEnd wdCharacter, 1
    Selection.Font.Reset
    nmlSize = Selection.Font.Size
    nmlFont = Selection.Font.Name
    nmlColour = Selection.Font.Color
    wasBold = Selection.Font.Bold
    wasItalic = Selection.Font.Italic
    wasSuper = Selection.Font.Superscript
    wasSub = Selection.Font.Subscript
    wasSmalls = Selection.Font.SmallCaps

  ' undo the change, i.e. restore the text's original attributes
    WordBasic.EditUndo
  ' Check the text's emphasis now
    isBold = Selection.Font.Bold
    isItalic = Selection.Font.Italic
    isSuper = Selection.Font.Superscript
    isSub = Selection.Font.Subscript
    isSmalls = Selection.Font.SmallCaps
    isStrike = Selection.Font.StrikeThrough
    isDStrike = Selection.Font.DoubleStrikeThrough
    isUnderline = Selection.Font.Underline
    thisSize = Selection.Font.Size
    thisFont = Selection.Font.Name
    thisColour = Selection.Font.Color

Case Else
' A number 1 to 9
  If myText = "#" Then
    myNumber = -99
    myText = "^#"
  Else
    myNumber = Val(Chr(Asc(myText)))
  End If
  If myNumber > 0 And myNumber < 10 Then
  ' A caption/heading with the same first three characters
    Selection.HomeKey Unit:=wdLine
    Selection.MoveEnd wdCharacter, myNumber
    myFind = "[^t^11^12^13]" & Replace(Selection, "<", "\<")
    mvStart = 1
    WC = True
  Else

' Absolutely every other input gives a straight non-WC find
    myFind = myText
    WC = False
  End If
End Select

If myText = "e" Then selText = Trim(existingFind): GoTo inputCommand

GoTo goFind

' See if it's a page, fnote, enote or section number
moreText:
'Debug.Print selText
'Debug.Print myText
startChar = Left(LCase(myText), 1)
lastChar = Asc(Right(myText, 1))
If lastChar > 47 And lastChar < 58 And Len(myText) <= 4 Then
' The final chacter is a number
  isACode = True
  Select Case startChar
    Case "p"
      Selection.GoTo What:=wdGoToPage, count:=Mid(myText, 2)
    Case "n"
      Selection.GoTo What:=wdGoToFootnote, count:=Mid(myText, 2)
    Case "f"
      Selection.GoTo What:=wdGoToFootnote, count:=Mid(myText, 2)
    Case "e"
      Selection.GoTo What:=wdGoToEndnote, count:=Mid(myText, 2)
    Case "c"
      Selection.GoTo What:=wdGoToComment, count:=Mid(myText, 2)
    Case "s"
      Set rng = ActiveDocument.Content
      With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13\>^t]" & Mid(myText, 2)
        .MatchCase = False
        .MatchWildcards = True
        .MatchWholeWord = False
        .MatchSoundsLike = False
        .Wrap = wdFindStop
        .Forward = True
        .Execute
      End With
      If rng.Find.Found = True Then
        rng.Select
        Selection.MoveStart wdCharacter, 1
      Else
        Beep
        Selection.start = endMyText
      End If
    Case Else
      isACode = False
  End Select
  If isACode = True Then
    If ActiveDocument.Footnotes.count >= 1 And InStr("fn", startChar) > 0 _
         Then ActiveDocument.ActiveWindow.View.SeekView = wdSeekFootnotes
    If ActiveDocument.Endnotes.count >= 1 And startChar = "e" Then _
         ActiveDocument.ActiveWindow.View.SeekView = wdSeekEndnotes
    Exit Sub
  End If
End If

' If not a special command, then it's ordinary text to find
If Len(myText) = 2 Then
  myCase = True
  Select Case myText
    Case "ap": myText = "Appendix "
    Case "re": myText = "References": myCase = False
    Case "fi": myText = "Figure"
    Case "[": myText = "[[[[["
    Case "se": myText = "| Spelling Errors"
    Case "mm": myText = "^s^s^s^s^s"
    Case "ii": myText = "(Preparing your brief or style guide)"
    Case "op": myText = "When I want to change"
    Case "st": myText = "What is this document?"
  End Select
End If
myFind = myText
If myReplace > "" Then myReplace = myText
WC = False

goFind:
Selection.start = Selection.End
' Go and look for the word
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = myFind
  If Len(myStyle) > 0 And myStyle <> "Normal" Then .Style = myStyle
  .Replacement.Text = myReplace
  .Forward = True
  .MatchCase = myCase
  .MatchWildcards = WC
  .MatchWholeWord = wholeWds
  .MatchSoundsLike = sndsLike
  .MatchAllWordForms = allForms
  If isBold Then .Font.Bold = True
  If isItalic Then .Font.Italic = True
  If isSuper Then .Font.Superscript = True
  If isSub Then .Font.Subscript = True
  If isSmalls Then .Font.SmallCaps = True
  If isStrike Then .Font.StrikeThrough = True
  If isDStrike Then .Font.DoubleStrikeThrough = True
  If isUnderline Then .Font.Underline = True
  If thisSize <> nmlSize Then .Font.Size = thisSize
  If thisFont <> nmlFont Then .Font.Name = thisFont
  If thisColour <> nmlColour Then .Font.Color = thisColour
  .Wrap = wdFindStop
  .Forward = True
  .Execute
End With

If (Selection.start = 0 Or Selection.start = endMyText Or _
     Selection.End = cursorPosn) And WC = False Then
'If Selection.Start = endMyText Or Selection.End = cursorPosn Then
  Beep
  Selection.End = startMyText
  Selection.start = startMyText
  With Selection.Find
    .Forward = False
    .Execute
  End With
Else
  With Selection.Find
    .Forward = True
    .Execute
  End With
  If Selection.start > hereNow Then
    With Selection.Find
      .Forward = False
      .Execute
    End With
  End If
End If
If mvStart > 0 Then Selection.MoveStart wdCharacter, mvStart
If mvEnd > 0 Then Selection.MoveEnd wdCharacter, mvEnd

With Selection.Find
  If myText = "[" Then .Text = existingFind
  .Forward = True
  .Wrap = wdFindContinue
End With
End Sub