Sub ConvertHyperlinks()
Dim RngFld As Range, RngTmp As Range, oFld As Field, StrTmp As String, HLink As Hyperlink
' Turn Off Screen Updating
Application.ScreenUpdating = False
ActiveDocument.ActiveWindow.View.ShowFieldCodes = True
Set RngFld = ActiveDocument.Range
With RngFld
  'Convert HREF codes to {HYPERLINK \1}«\2» format
  With .Find
    .Text = "\<[Aa] href=([!\>]{1,})\>([!\<]{1,})\</a\>"
    .ClearFormatting
    .Replacement.ClearFormatting
    .Replacement.Text = "{HYPERLINK \1}«\2»"
    .Forward = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  'Validate content
  If Len(Replace(.Text, "{", vbNullString)) <> Len(Replace(.Text, "}", vbNullString)) Then
    MsgBox "Unmatched field brace pairs in the document.", vbCritical + vbOKOnly, "Error!"
    Exit Sub
  End If
  If Len(Replace(.Text, "«", vbNullString)) <> Len(Replace(.Text, "»", vbNullString)) Then
    MsgBox "Unmatched 'Text to display' tags in the document.", vbCritical + vbOKOnly, "Error!"
    Exit Sub
  End If
  'Convert Hyperlink fields
  Do While InStr(1, .Text, "{") > 0
    Set RngTmp = ActiveDocument.Range(Start:=.Start + _
        InStr(.Text, "{") - 1, End:=.Start + InStr(.Text, "}"))
    With RngTmp
      Do While Len(Replace(.Text, "{", vbNullString)) <> _
          Len(Replace(.Text, "}", vbNullString))
        .End = .End + 1
        If .Characters.Last.Text <> "}" Then .MoveEndUntil cset:="}", _
          Count:=Len(ActiveDocument.Range(.End, RngFld.End))
      Loop
      .Characters.First = vbNullString
      .Characters.Last = vbNullString
      StrTmp = .Text
      Set oFld = ActiveDocument.Fields.Add(Range:=RngTmp, _
          Type:=wdFieldEmpty, Text:="", PreserveFormatting:=False)
      oFld.Code.Text = StrTmp
    End With
  Loop
  ActiveDocument.ActiveWindow.View.ShowFieldCodes = False
  'update the field display
  .Fields.Update
  'Update the hyperlink 'Text To Display' values
  For Each HLink In .Hyperlinks
    Set RngTmp = HLink.Range
    With RngTmp
      If .Characters.Last.Next = "«" Then
        .MoveEndUntil cset:="»"
        .MoveStartUntil cset:="«"
        .Characters.First.Delete
        .Characters.Last.Next.Delete
        HLink.TextToDisplay = Trim(.Text)
        .Delete
      End If
    End With
  Next
End With
Set RngTmp = Nothing: Set RngFld = Nothing: Set oFld = Nothing
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub