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

Sub Macro1()
Dim oRng As Range
Dim oWord As Range
    Set oRng = ActiveDocument.Range
    With oRng.Find
        Do While .Execute(FindText:="_")
            Set oWord = oRng.Duplicate
            If oWord.Words(1).Start <> ActiveDocument.Range.Start Then
                oWord.MoveStartUntil Chr(32), wdBackward
                oWord.MoveEndUntil Chr(32) & Chr(13)
                If InStr(1, oWord.Text, "@") = 0 Then oRng.Text = " "
            End If
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Set oWord = Nothing
    Exit Sub
End Sub

Sub Macro1()
  Dim aHL As Hyperlink
  With Options
    .AutoFormatApplyHeadings = False
    .AutoFormatApplyLists = False
    .AutoFormatApplyBulletedLists = False
    .AutoFormatApplyOtherParas = False
    .AutoFormatReplaceQuotes = False
    .AutoFormatReplaceSymbols = False
    .AutoFormatReplaceOrdinals = False
    .AutoFormatReplaceFractions = False
    .AutoFormatReplacePlainTextEmphasis = False
    .AutoFormatReplaceHyperlinks = True
    .AutoFormatPreserveStyles = True
    .AutoFormatPlainTextWordMail = True
    .LabelSmartTags = False
  End With
  ActiveDocument.Range.AutoFormat

  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "_"
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
  End With
  For Each aHL In ActiveDocument.Range.Hyperlinks
    If aHL.Type = msoHyperlinkRange Then
      aHL.TextToDisplay = Replace(aHL.Address, "mailto:", "")
    End If
  Next aHL
End Sub