Sub Demo()
Application.ScreenUpdating = False
Dim Hlnk As Hyperlink
With ActiveDocument
  With .Range
    'Activate email addresses as hyperinks
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "<[0-9A-?.\-_]{1,}\@[0-9A-?\-_]{1,}.[a-z]{2,3}>"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      .Hyperlinks.Add Anchor:=.Duplicate, Address:="mailto:" & .Text, TextToDisplay:=.Text
      .Start = .Hyperlinks(1).Range.End
      .Find.Execute
    Loop
    'Replace underscores with spaces
    With .Find
      .Text = "_"
      .Replacement.Text = " "
      .Wrap = wdFindContinue
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
  End With
  'Repair email address underscores
  For Each Hlnk In .Hyperlinks
    With Hlnk
      If InStr(.Address, "mailto:") > 0 Then .TextToDisplay = Split(.Address, "mailto:")(1)
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub